void do_matrixApply(SEXP ans,
                    SEXP data,
                    SEXP margin,
                    SEXP function,
                    int my_start,
                    int my_end,
                    int *dimensions,
                    int worldRank)
{

  SEXP data_chunk, R_fcall, parsedCmd = R_NilValue;
  int i, j;
  double *rdata, *rchunk;

  rdata = REAL(data);

  PROTECT(parsedCmd = parseExpression(function));

  /* Create R LANGSXP Vector, R function holder
     length of the vector is 1 + number of arguments */
  PROTECT(R_fcall = lang2(VECTOR_ELT(parsedCmd, 0), R_NilValue));
 
  if (INTEGER(margin)[0] == 1) {

    PROTECT(data_chunk = allocVector(REALSXP, dimensions[1]));
    rchunk = REAL(data_chunk);

    for(i=0; i<my_end-my_start; i++) {

      /* Master process won't have data aligned in memory in this case */
      if (worldRank != MASTER_PROCESS) {

        for(j=0; j<dimensions[1]; j++) {
          rchunk[j] = rdata[i*dimensions[1]+j];
        }
        
      } else {

        for(j=0; j<dimensions[1]; j++) {
          rchunk[j] = rdata[j*dimensions[0]+i];
        }
      }
      
      SETCADR(R_fcall, data_chunk);
      SET_VECTOR_ELT(ans, i, eval(R_fcall, R_GlobalEnv));
      
      }    
  } else if (INTEGER(margin)[0] == 2) {

    PROTECT(data_chunk = allocVector(REALSXP, dimensions[0]));
    rchunk = REAL(data_chunk);
   
    for(i=0; i<my_end-my_start; i++) {
      
      for(j=0; j<dimensions[0]; j++) {
        rchunk[j] = rdata[j+i*dimensions[0]];
      }

      SETCADR(R_fcall, data_chunk);
      SET_VECTOR_ELT(ans, i, eval(R_fcall, R_GlobalEnv));

    }
  }
  
  UNPROTECT(3);
  return;
  
}
Пример #2
0
// [[register]]
SEXP unmelt(SEXP data, SEXP uniq_id, SEXP other_ind_, SEXP id_ind_, SEXP value_ind_) {

	// int id_ind = asInteger(id_ind_);
	int value_ind = asInteger(value_ind_);
	int* other_ind = INTEGER(other_ind_);
	int nRow = (int)(length(VECTOR_ELT(data, 0)) / length(uniq_id));
	int numprotect = 0;

	if (TYPEOF(uniq_id) != STRSXP) {
		GUARD(uniq_id = coerceVector(uniq_id, STRSXP));
	}

	int n_uniq = length(uniq_id);

	SEXP output;
	GUARD(output = allocVector(VECSXP, length(other_ind_) + length(uniq_id)));

	int n_other = length(other_ind_);

	// ensure that the unmelting process will go smoothly
#define HANDLE_CASE(RTYPE, CTYPE, ACCESSOR) \
		case RTYPE: { \
			CTYPE* tmp = ACCESSOR( VECTOR_ELT(data, other_ind[i]) ); \
			for (int j=0; j < nRow; ++j) { \
				for (int k=1; k < n_uniq; ++k) { \
					if (tmp[j] != tmp[j + nRow*k]) { \
						Rf_error("Mismatch in elements at indices %i and %i in vector %s", j+1, j + nRow*k+1, CHAR(STRING_ELT(getAttrib(data, R_NamesSymbol), other_ind[i]))); \
					} \
				} \
			} \
			break; \
		} \


	if (n_uniq > 1) {
		for (int i=0; i < n_other; ++i) {
			switch (TYPEOF(VECTOR_ELT(data, other_ind[i]))) {
			HANDLE_CASE(LGLSXP, int, LOGICAL);
			HANDLE_CASE(INTSXP, int, INTEGER);
			HANDLE_CASE(REALSXP, double, REAL);
			HANDLE_CASE(STRSXP, SEXP, STRING_PTR);
			default: Rf_error("Unhandled type %s", type2char(TYPEOF(VECTOR_ELT(data, other_ind[i]))));
			}
		}
	}

#undef HANDLE_CASE

	// copy in the 'other' variables first
#define COPY(RTYPE, CTYPE, ACCESSOR) { \
		PROTECT(tmp = allocVector(RTYPE, nRow)); \
		CTYPE* tmp_ptr = ACCESSOR(tmp); \
		CTYPE* data_ptr = ACCESSOR(VECTOR_ELT(data, other_ind[i])); \
		for (int i=0; i < nRow; ++i) { \
			tmp_ptr[i] = data_ptr[i]; \
		} \
		SET_VECTOR_ELT(output, i, tmp); \
		UNPROTECT(1); \
		break; \
		} \

	SEXP tmp;
	for (int i=0; i < n_other; ++i) {
		switch (TYPEOF(VECTOR_ELT(data, other_ind[i]))) {
		case LGLSXP: COPY(LGLSXP, int, LOGICAL);
		case INTSXP: COPY(INTSXP, int, INTEGER);
		case REALSXP: COPY(REALSXP, double, REAL);
		case STRSXP: COPY(STRSXP, SEXP, STRING_PTR);
		default: Rf_error("Unhandled SEXP type");
		}
	}

#undef COPY

#define COPY(RTYPE, CTYPE, ACCESSOR) { \
		PROTECT(tmp = allocVector(RTYPE, nRow)); \
		CTYPE* tmp_ptr = ACCESSOR(tmp); \
		CTYPE* data_ptr = ACCESSOR(VECTOR_ELT(data, value_ind)); \
		for (int j=0; j < nRow; ++j) { \
			tmp_ptr[j] = data_ptr[j + (i*nRow)]; \
		} \
		SET_VECTOR_ELT(output, i + n_other, tmp); \
		UNPROTECT(1); \
		break; \
		} \

	// copy the value
	int valuetype = TYPEOF(VECTOR_ELT(data, value_ind));
	for (int i=0; i < n_uniq; ++i) {
		switch (valuetype) {
		case LGLSXP: COPY(LGLSXP, int, LOGICAL);
		case INTSXP: COPY(INTSXP, int, INTEGER);
		case REALSXP: COPY(REALSXP, double, REAL);
		case STRSXP: COPY(STRSXP, SEXP, STRING_PTR);
		}
	}

	// set the names
	SEXP datanames = getAttrib(data, R_NamesSymbol);
	SEXP names;
	GUARD(names = allocVector(STRSXP, n_other + n_uniq));
	for (int i=0; i < n_other; ++i) {
		SET_STRING_ELT(names, i, STRING_ELT(datanames, i));
	}
	for (int i=0; i < n_uniq; ++i) {
		SET_STRING_ELT(names, n_other+i, STRING_ELT(uniq_id, i));
	}
	setAttrib(output, R_NamesSymbol, names);

	// set the class
	setAttrib(output, R_ClassSymbol, mkString("data.frame"));

	// set the rows
	SEXP rownames;
	GUARD( rownames=allocVector(INTSXP, nRow) );
	int* rownames_ptr = INTEGER(rownames);
	for (int i=0; i < nRow; ++i) {
		rownames_ptr[i] = i+1;
	}
	setAttrib(output, R_RowNamesSymbol, rownames);
	UNGUARD;
	return output;
}
Пример #3
0
/** get value of a field of an object or class
    object (int), return signature (string), field name (string)
    arrays and objects are returned as IDs (hence not evaluated)
    class name can be in either form / or .
*/
REPC SEXP RgetField(SEXP obj, SEXP sig, SEXP name, SEXP trueclass) {
  jobject o = 0;
  SEXP e;
  const char *retsig, *fnam;
  char *clnam = 0, *detsig = 0;
  jfieldID fid;
  jclass cls;
  int tc = asInteger(trueclass);
  JNIEnv *env=getJNIEnv();

  if (obj == R_NilValue) return R_NilValue;
  if ( IS_JOBJREF(obj) )
    obj = GET_SLOT(obj, install("jobj"));
  if (TYPEOF(obj)==EXTPTRSXP) {
    jverify(obj);
    o=(jobject)EXTPTR_PTR(obj);
  } else if (TYPEOF(obj)==STRSXP && LENGTH(obj)==1)
    clnam = strdup(CHAR(STRING_ELT(obj, 0)));
  else
    error("invalid object parameter");
  if (!o && !clnam)
    error("cannot access a field of a NULL object");
#ifdef RJ_DEBUG
  if (o) {
    rjprintf("RgetField.object: "); printObject(env, o);
  } else {
    rjprintf("RgetField.class: %s\n", clnam);
  }
#endif
  if (o)
    cls = objectClass(env, o);
  else {
    char *c = clnam;
    while(*c) { if (*c=='/') *c='.'; c++; }
    cls = findClass(env, clnam);
    free(clnam);
    if (!cls) {
      error("cannot find class %s", CHAR(STRING_ELT(obj, 0)));
    }
  }
  if (!cls)
    error("cannot determine object class");
#ifdef RJ_DEBUG
  rjprintf("RgetField.class: "); printObject(env, cls);
#endif
  if (TYPEOF(name)!=STRSXP || LENGTH(name)!=1) {
    releaseObject(env, cls);
    error("invalid field name");
  }
  fnam = CHAR(STRING_ELT(name,0));
  if (sig == R_NilValue) {
    retsig = detsig = findFieldSignature(env, cls, fnam);
    if (!retsig) {
      releaseObject(env, cls);
      error("unable to detect signature for field '%s'", fnam);
    }
  } else {
    if (TYPEOF(sig)!=STRSXP || LENGTH(sig)!=1) {
      releaseObject(env, cls);
      error("invalid signature parameter");
    }
    retsig = CHAR(STRING_ELT(sig,0));
  }
  _dbg(rjprintf("field %s signature is %s\n",fnam,retsig));
  
  if (o) { /* first try non-static fields */
    fid = (*env)->GetFieldID(env, cls, fnam, retsig);
    checkExceptionsX(env, 1);
    if (!fid) { /* if that fails, try static ones */
      o = 0;
      fid = (*env)->GetStaticFieldID(env, cls, fnam, retsig);
    }
  } else /* no choice if the object was a string */
    fid = (*env)->GetStaticFieldID(env, cls, fnam, retsig);

  if (!fid) {
    checkExceptionsX(env, 1);
    releaseObject(env, cls);
    if (detsig) free(detsig);
    error("RgetField: field %s not found", fnam);
  }
  switch (*retsig) {
  case 'I': {
    int r=o?
      (*env)->GetIntField(env, o, fid):
      (*env)->GetStaticIntField(env, cls, fid);
    e = allocVector(INTSXP, 1);
    INTEGER(e)[0] = r;
    releaseObject(env, cls);
    if (detsig) free(detsig);
    return e;
  }
  case 'S': {
    jshort r=o?
      (*env)->GetShortField(env, o, fid):
      (*env)->GetStaticShortField(env, cls, fid);
    e = allocVector(INTSXP, 1);
    INTEGER(e)[0] = r;
    releaseObject(env, cls);
    if (detsig) free(detsig);
    return e;
  }
  case 'C': {
    int r=(int) (o?
		 (*env)->GetCharField(env, o, fid):
		 (*env)->GetStaticCharField(env, cls, fid));
    e = allocVector(INTSXP, 1);
    INTEGER(e)[0] = r;
    releaseObject(env, cls);
    if (detsig) free(detsig);
    return e;
  }
  case 'B': {
    int r=(int) (o?
		 (*env)->GetByteField(env, o, fid):
		 (*env)->GetStaticByteField(env, cls, fid));
    e = allocVector(INTSXP, 1);
    INTEGER(e)[0] = r;
    releaseObject(env, cls);
    if (detsig) free(detsig);
    return e;
  }
  case 'J': {
    jlong r=o?
      (*env)->GetLongField(env, o, fid):
      (*env)->GetStaticLongField(env, cls, fid);
    e = allocVector(REALSXP, 1);
    REAL(e)[0] = (double)r;
    releaseObject(env, cls);
    if (detsig) free(detsig);
    return e;
  }
  case 'Z': {
    jboolean r=o?
      (*env)->GetBooleanField(env, o, fid):
      (*env)->GetStaticBooleanField(env, cls, fid);
    e = allocVector(LGLSXP, 1);
    LOGICAL(e)[0] = r?1:0;
    releaseObject(env, cls);
    if (detsig) free(detsig);
    return e;
  }
  case 'D': {
    double r=o?
      (*env)->GetDoubleField(env, o, fid):
      (*env)->GetStaticDoubleField(env, cls, fid);
    e = allocVector(REALSXP, 1);
    REAL(e)[0] = r;
    releaseObject(env, cls);
    if (detsig) free(detsig);
    return e;
  }
  case 'F': {
    double r = (double) (o?
      (*env)->GetFloatField(env, o, fid):
      (*env)->GetStaticFloatField(env, cls, fid));
    e = allocVector(REALSXP, 1);
    REAL(e)[0] = r;
    releaseObject(env, cls);
    if (detsig) free(detsig);
    return e;
  }
  case 'L':
  case '[': {
    SEXP rv;
    jobject r = o?
      (*env)->GetObjectField(env, o, fid):
      (*env)->GetStaticObjectField(env, cls, fid);
    _mp(MEM_PROF_OUT("  %08x LNEW field value\n", (int) r))
    releaseObject(env, cls);
    if (tc) {
      if (detsig) free(detsig);
      return new_jobjRef(env, r, 0);
    }
    if (*retsig=='L') { /* need to fix the class name */      
      char *d = strdup(retsig), *c = d;
      while (*c) { if (*c==';') { *c=0; break; }; c++; }
      rv = new_jobjRef(env, r, d+1);
      free(d);
    } else
      rv = new_jobjRef(env, r, retsig);
    if (detsig) free(detsig);
    return rv;
  }
  } /* switch */
  releaseObject(env, cls);
  if (detsig) {
    free(detsig);
    error("unknown field signature");
  }
  error("unknown field signature '%s'", retsig);
  return R_NilValue;
}
Пример #4
0
Файл: objects.c Проект: cran/SMC
Sampler *
sampler_new (SEXP opts)
{
        Sampler *ss;
        SEXP SEXPTmp;
        
        ss                    = (Sampler *) R_alloc(1, sizeof(struct Sampler));
        ss->nStreams          = INTEGER(getListElement(opts, "nStreams"))[0];
        ss->nPeriods          = INTEGER(getListElement(opts, "nPeriods"))[0];
        ss->nStreamsPreResamp = INTEGER(getListElement(opts, "nStreamsPreResamp"))[0];
        ss->dimPerPeriod      = INTEGER(getListElement(opts, "dimPerPeriod"))[0];
        ss->dimSummPerPeriod  = INTEGER(getListElement(opts, "dimSummPerPeriod"))[0];
        ss->returnStreams     = LOGICAL(getListElement(opts, "returnStreams"))[0];
        ss->returnLogWeights  = LOGICAL(getListElement(opts, "returnLogWeights"))[0];
        ss->nMHSteps          = INTEGER(getListElement(opts, "nMHSteps"))[0];
        ss->verboseLevel      = INTEGER(getListElement(opts, "verboseLevel"))[0];

        ss->printEstTimeAt = 10; ss->printEstTimeNTimes = 10;
        /* FIXME: The setting for ss->printDotAt, is it all right? */
        ss->printInitialDotsWhen = ss->printEstTimeAt / 10;
        ss->printDotAt = 0; ss->nDotsPerLine = 20;
        ss->eachDotWorth = (int) ceil((ss->nPeriods - ss->printEstTimeAt + 1.0) / \
                                      (ss->printEstTimeNTimes * ss->nDotsPerLine));
        ss->nProtected = 0;

        /* The user provided functions */
        ss->propagateFunc     = getListElement(opts, "propagateFunc");
        ss->propagateArgsList = (ArgsList1 *) R_alloc(1, sizeof(struct ArgsList1));
        ss->nProtected       += args_list1_init(ss->propagateArgsList);        

        ss->resampCriterionFunc     = getListElement(opts, "resampCriterionFunc");
        ss->resampCriterionArgsList = (ArgsList2 *) R_alloc(1, sizeof(struct ArgsList2));
        ss->nProtected             += args_list2_init(ss->resampCriterionArgsList);

        ss->resampFunc     = getListElement(opts, "resampFunc");
        ss->resampArgsList = (ArgsList2 *) R_alloc(1, sizeof(struct ArgsList2));
        ss->nProtected    += args_list2_init(ss->resampArgsList);

        ss->summaryFunc     = getListElement(opts, "summaryFunc");
        ss->summaryArgsList = (ArgsList2 *) R_alloc(1, sizeof(struct ArgsList2));
        ss->nProtected     += args_list2_init(ss->summaryArgsList);

        ss->MHUpdateFunc     = getListElement(opts, "MHUpdateFunc");
        ss->MHUpdateArgsList = (ArgsList3 *) R_alloc(1, sizeof(struct ArgsList3));
        ss->nProtected      += args_list3_init(ss->MHUpdateArgsList);
        
        SEXPTmp = getListElement(opts, "doCallFunc");
        PROTECT(ss->doCallFuncCall = lang4(SEXPTmp, R_NilValue,
                                           R_NilValue, R_NilValue));
        ++(ss->nProtected);
        ss->doCallFuncEnv = getListElement(opts, "doCallFuncEnv");
        
        SEXPTmp = getListElement(opts, "procTimeFunc");
        PROTECT(ss->procTimeFuncCall = lang1(SEXPTmp));
        ++(ss->nProtected);
        ss->procTimeFuncEnv = getListElement(opts, "procTimeFuncEnv");

        ss->timeDetails = (TimeDetails *) R_alloc(1, sizeof(struct TimeDetails));

        PROTECT(ss->SEXPCurrentPeriod = allocVector(INTSXP, 1)); ++(ss->nProtected);
        PROTECT(ss->SEXPNStreamsToGenerate = allocVector(INTSXP, 1)); ++(ss->nProtected);
        PROTECT(ss->SEXPNMHSteps = allocVector(INTSXP, 1)); ++(ss->nProtected);

        ss->dotsList = getListElement(opts, "dotsList");

        ss->SEXPCurrentStreams      = R_NilValue;
        PROTECT(ss->SEXPLag1Streams = allocMatrix(REALSXP, ss->nStreams, ss->dimPerPeriod));
        ++(ss->nProtected);

        ss->SEXPCurrentLogWeights           = R_NilValue;
        PROTECT(ss->SEXPCurrentAdjWeights   = allocVector(REALSXP, ss->nStreamsPreResamp));
        ++(ss->nProtected);
        PROTECT(ss->SEXPLag1LogWeights      = allocVector(REALSXP, ss->nStreams));
        ++(ss->nProtected);
        PROTECT(ss->SEXPLag1AdjWeights      = allocVector(REALSXP, ss->nStreams));
        ++(ss->nProtected);
        PROTECT(ss->SEXPAcceptanceRates     = allocVector(REALSXP, ss->nStreams));
        ++(ss->nProtected);
        PROTECT(ss->SEXPSummary             = allocVector(REALSXP, ss->dimSummPerPeriod));
        ++(ss->nProtected);
        PROTECT(ss->SEXPPropUniqueStreamIds = allocVector(REALSXP, 1));
        ++(ss->nProtected);
        
        ss->scratch_RC                  = (ResampleContext *) R_alloc(1, sizeof(struct ResampleContext));
        ss->scratch_RC->streamIds       = (int *) R_alloc(ss->nStreams, sizeof(int));
        ss->scratch_RC->uniqueStreamIds = (int *) R_alloc(ss->nStreams, sizeof(int));
        ss->scratch_RC->partialSum      = (double *) R_alloc(ss->nStreamsPreResamp, sizeof(double));
        return ss;
}
Пример #5
0
SEXP R_num_to_char(SEXP x, SEXP digits, SEXP na_as_string, SEXP use_signif) {
  int len = length(x);
  int na_string = asLogical(na_as_string);
  int signif = asLogical(use_signif);
  char buf[32];
  SEXP out = PROTECT(allocVector(STRSXP, len));
  if(isInteger(x)){
    for (int i=0; i<len; i++) {
      if(INTEGER(x)[i] == NA_INTEGER){
        if(na_string == NA_LOGICAL){
          SET_STRING_ELT(out, i, NA_STRING);
        } else if(na_string){
          SET_STRING_ELT(out, i, mkChar("\"NA\""));
        } else {
          SET_STRING_ELT(out, i, mkChar("null"));
        }
      } else {
        modp_itoa10(INTEGER(x)[i], buf);
        SET_STRING_ELT(out, i, mkChar(buf));
      }
    }
  } else if(isReal(x)) {
    int precision = asInteger(digits);
    double * xreal = REAL(x);
    for (int i=0; i<len; i++) {
      double val = xreal[i];
      if(!R_FINITE(val)){
        if(na_string == NA_LOGICAL){
          SET_STRING_ELT(out, i, NA_STRING);
        } else if(na_string){
          if(ISNA(val)){
            SET_STRING_ELT(out, i, mkChar("\"NA\""));
          } else if(ISNAN(val)){
            SET_STRING_ELT(out, i, mkChar("\"NaN\""));
          } else if(val == R_PosInf){
            SET_STRING_ELT(out, i, mkChar("\"Inf\""));
          } else if(val == R_NegInf){
            SET_STRING_ELT(out, i, mkChar("\"-Inf\""));
          } else {
            error("Unrecognized non finite value.");
          }
        } else {
          SET_STRING_ELT(out, i, mkChar("null"));
        }
      } else if(precision == NA_INTEGER){
        snprintf(buf, 32, "%.15g", val);
        SET_STRING_ELT(out, i, mkChar(buf));
      } else if(signif){
        //use signifant digits rather than decimal digits
        snprintf(buf, 32, "%.*g", (int) ceil(fmin(15, precision)), val);
        SET_STRING_ELT(out, i, mkChar(buf));
      } else if(precision > -1 && precision < 10 && fabs(val) < 2147483647 && fabs(val) > 1e-5) {
        //preferred method: fast with fixed decimal digits
        //does not support large numbers or scientific notation
        modp_dtoa2(val, buf, precision);
        SET_STRING_ELT(out, i, mkChar(buf));
        //Rprintf("Using modp_dtoa2\n");
      } else {
        //fall back on sprintf (includes scientific notation)
        //limit total precision to 15 significant digits to avoid noise
        //funky formula is mostly to convert decimal digits into significant digits
        snprintf(buf, 32, "%.*g", (int) ceil(fmin(15, fmax(1, log10(val)) + precision)), val);
        SET_STRING_ELT(out, i, mkChar(buf));
        //Rprintf("Using sprintf with precision %d digits\n",(int) ceil(fmin(15, fmax(1, log10(val)) + precision)));
      }
    }
  } else {
    error("num_to_char called with invalid object type.");
  }

  UNPROTECT(1);
  return out;
}
Пример #6
0
                    b = twiddle(ulv, thisi, 1) == twiddle(ulv, previ, 1);
                }
                break;
                // TO DO: store previ twiddle call, but it'll need to be vector since this is in a loop through columns. Hopefully the first == will short circuit most often
            default :
                error("Type '%s' not supported", type2char(TYPEOF(v))); 
            }
        }
        if (!b) iidx[len++] = i+1;
        if (len >= isize) {
            isize = 1.1*isize*nrow/i;
            n_iidx = Realloc(iidx, isize, int);
            if (n_iidx != NULL) iidx = n_iidx; else error("Error in reallocating memory in 'uniqlist'\n");
        }
    }
    PROTECT(ans = allocVector(INTSXP, len));
    memcpy(INTEGER(ans), iidx, sizeof(int)*len); // sizeof is of type size_t - no integer overflow issues   
    Free(iidx);
    UNPROTECT(1);
    return(ans);
}

SEXP uniqlengths(SEXP x, SEXP n) {
    SEXP ans;
    R_len_t i, len;
    if (TYPEOF(x) != INTSXP || length(x) < 0) error("Input argument 'x' to 'uniqlengths' must be an integer vector of length >= 0");
    if (TYPEOF(n) != INTSXP || length(n) != 1) error("Input argument 'n' to 'uniqlengths' must be an integer vector of length 1");
    PROTECT(ans = allocVector(INTSXP, length(x)));
    len = length(x);
    for (i=1; i<len; i++) {
        INTEGER(ans)[i-1] = INTEGER(x)[i] - INTEGER(x)[i-1];
Пример #7
0
SEXP minc2_apply(SEXP filenames, SEXP fn, SEXP have_mask, 
		 SEXP mask, SEXP mask_value, SEXP rho) {
  int                result;
  mihandle_t         *hvol, hmask;
  int                i, v0, v1, v2, output_index, buffer_index;
  unsigned long     start[3], count[3];
  //unsigned long      location[3];
  int                num_files;
  double             *xbuffer, *xoutput, **full_buffer;
  double             *xhave_mask, *xmask_value;
  double             *mask_buffer;
  midimhandle_t      dimensions[3];
  misize_t            sizes[3];
  SEXP               output, buffer;
  //SEXP               R_fcall;
  

  /* allocate memory for volume handles */
  num_files = LENGTH(filenames);
  hvol = malloc(num_files * sizeof(mihandle_t));

  Rprintf("Number of volumes: %i\n", num_files);

  /* open the mask - if so desired */
  xhave_mask = REAL(have_mask);
  if (xhave_mask[0] == 1) {
    result = miopen_volume(CHAR(STRING_ELT(mask, 0)),
			   MI2_OPEN_READ, &hmask);
    if (result != MI_NOERROR) {
      error("Error opening mask: %s.\n", CHAR(STRING_ELT(mask, 0)));
    }
  }
  
  /* get the value inside that mask */
  xmask_value = REAL(mask_value);

  /* open each volume */
  for(i=0; i < num_files; i++) {
    result = miopen_volume(CHAR(STRING_ELT(filenames, i)),
      MI2_OPEN_READ, &hvol[i]);
    if (result != MI_NOERROR) {
      error("Error opening input file: %s.\n", CHAR(STRING_ELT(filenames,i)));
    }
  }

  /* get the file dimensions and their sizes - assume they are the same*/
  miget_volume_dimensions( hvol[0], MI_DIMCLASS_SPATIAL,
			   MI_DIMATTR_ALL, MI_DIMORDER_FILE,
			   3, dimensions);
  result = miget_dimension_sizes( dimensions, 3, sizes );
  Rprintf("Volume sizes: %i %i %i\n", sizes[0], sizes[1], sizes[2]);

  /* allocate the output buffer */
  PROTECT(output=allocVector(REALSXP, (sizes[0] * sizes[1] * sizes[2])));
  xoutput = REAL(output);

  /* allocate the local buffer that will be passed to the function */
  PROTECT(buffer=allocVector(REALSXP, num_files));
  xbuffer = REAL(buffer); 

  //PROTECT(R_fcall = lang2(fn, R_NilValue));


  /* allocate first dimension of the buffer */
  full_buffer = malloc(num_files * sizeof(double));

  /* allocate second dimension of the buffer 
     - big enough to hold one slice per subject at a time */
  for (i=0; i < num_files; i++) {
    full_buffer[i] = malloc(sizes[1] * sizes[2] * sizeof(double));
  }
  
  /* allocate buffer for mask - if necessary */
  if (xhave_mask[0] == 1) {
    mask_buffer = malloc(sizes[1] * sizes[2] * sizeof(double));
  }
	
  /* set start and count. start[0] will change during the loop */
  start[0] = 0; start[1] = 0; start[2] = 0;
  count[0] = 1; count[1] = sizes[1]; count[2] = sizes[2];

  /* loop across all files and voxels */
  Rprintf("In slice \n");
  for (v0=0; v0 < sizes[0]; v0++) {
    start[0] = v0;
    for (i=0; i < num_files; i++) {
      if (miget_real_value_hyperslab(hvol[i], 
				     MI_TYPE_DOUBLE, 
				     (misize_t *) start, 
				     (misize_t *) count, 
				     full_buffer[i]) )
	error("Error opening buffer.\n");
    }
    /* get mask - if desired */
    if (xhave_mask[0] == 1) {
      if (miget_real_value_hyperslab(hmask, 
				     MI_TYPE_DOUBLE, 
				     (misize_t *) start, 
				     (misize_t *) count, 
				     mask_buffer) )
	error("Error opening mask buffer.\n");
    }

    Rprintf(" %d ", v0);
    for (v1=0; v1 < sizes[1]; v1++) {
      for (v2=0; v2 < sizes[2]; v2++) {
	output_index = v0*sizes[1]*sizes[2]+v1*sizes[2]+v2;
	buffer_index = sizes[2] * v1 + v2;

	/* only perform operation if not masked */
	if(xhave_mask[0] == 0 
	   || (xhave_mask[0] == 1 && 
	       mask_buffer[buffer_index] > xmask_value[0] -0.5 &&
	       mask_buffer[buffer_index] < xmask_value[0] + 0.5)) {
	
	  for (i=0; i < num_files; i++) {
// 	    location[0] = v0;
// 	    location[1] = v1;
// 	    location[2] = v2;
	    //SET_VECTOR_ELT(buffer, i, full_buffer[i][index]);
	    //result = miget_real_value(hvol[i], location, 3, &xbuffer[i]);
	    xbuffer[i] = full_buffer[i][buffer_index];
	    
	    //Rprintf("V%i: %f\n", i, full_buffer[i][index]);

	  }
	  /* install the variable "x" into environment */
	  defineVar(install("x"), buffer, rho);
	  //SETCADDR(R_fcall, buffer);
	  //SET_VECTOR_ELT(output, index, eval(R_fcall, rho));
	  //SET_VECTOR_ELT(output, index, test);
	  /* evaluate the function */
	  xoutput[output_index] = REAL(eval(fn, rho))[0]; 
	}
	else {
	  xoutput[output_index] = 0;
	}
      }
    }
  }
  Rprintf("\nDone\n");

  /* free memory */
  for (i=0; i<num_files; i++) {
    miclose_volume(hvol[i]);
    free(full_buffer[i]);
  }
  free(full_buffer);
  UNPROTECT(2);

  /* return the results */
  return(output);
}
Пример #8
0
/* Note that NA_STRING is not handled separately here.  This is
   deliberate -- see ?paste -- and implicitly coerces it to "NA"
*/
SEXP attribute_hidden do_paste(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP ans, collapse, sep, x;
    int sepw, u_sepw, ienc;
    R_xlen_t i, j, k, maxlen, nx, pwidth;
    const char *s, *cbuf, *csep=NULL, *u_csep=NULL;
    char *buf;
    Rboolean allKnown, anyKnown, use_UTF8, use_Bytes,
	sepASCII = TRUE, sepUTF8 = FALSE, sepBytes = FALSE, sepKnown = FALSE,
	use_sep = (PRIMVAL(op) == 0);
    const void *vmax;

    checkArity(op, args);

    /* We use formatting and so we must initialize printing. */

    PrintDefaults();

    /* Check the arguments */

    x = CAR(args);
    if (!isVectorList(x))
	error(_("invalid first argument"));
    nx = xlength(x);

    if(use_sep) { /* paste(..., sep, .) */
	sep = CADR(args);
	if (!isString(sep) || LENGTH(sep) <= 0 || STRING_ELT(sep, 0) == NA_STRING)
	    error(_("invalid separator"));
	sep = STRING_ELT(sep, 0);
	csep = translateChar(sep);
	u_sepw = sepw = (int) strlen(csep); // will be short
	sepASCII = strIsASCII(csep);
	sepKnown = ENC_KNOWN(sep) > 0;
	sepUTF8 = IS_UTF8(sep);
	sepBytes = IS_BYTES(sep);
	collapse = CADDR(args);
    } else { /* paste0(..., .) */
	u_sepw = sepw = 0; sep = R_NilValue;/* -Wall */
	collapse = CADR(args);
    }
    if (!isNull(collapse))
	if(!isString(collapse) || LENGTH(collapse) <= 0 ||
	   STRING_ELT(collapse, 0) == NA_STRING)
	    error(_("invalid '%s' argument"), "collapse");
    if(nx == 0)
	return (!isNull(collapse)) ? mkString("") : allocVector(STRSXP, 0);


    /* Maximum argument length, coerce if needed */

    maxlen = 0;
    for (j = 0; j < nx; j++) {
	if (!isString(VECTOR_ELT(x, j))) {
	    /* formerly in R code: moved to C for speed */
	    SEXP call, xj = VECTOR_ELT(x, j);
	    if(OBJECT(xj)) { /* method dispatch */
		PROTECT(call = lang2(install("as.character"), xj));
		SET_VECTOR_ELT(x, j, eval(call, env));
		UNPROTECT(1);
	    } else if (isSymbol(xj))
		SET_VECTOR_ELT(x, j, ScalarString(PRINTNAME(xj)));
	    else
		SET_VECTOR_ELT(x, j, coerceVector(xj, STRSXP));

	    if (!isString(VECTOR_ELT(x, j)))
		error(_("non-string argument to internal 'paste'"));
	}
	if(xlength(VECTOR_ELT(x, j)) > maxlen)
	    maxlen = xlength(VECTOR_ELT(x, j));
    }
    if(maxlen == 0)
	return (!isNull(collapse)) ? mkString("") : allocVector(STRSXP, 0);

    PROTECT(ans = allocVector(STRSXP, maxlen));

    for (i = 0; i < maxlen; i++) {
	/* Strategy for marking the encoding: if all inputs (including
	 * the separator) are ASCII, so is the output and we don't
	 * need to mark.  Otherwise if all non-ASCII inputs are of
	 * declared encoding, we should mark.
	 * Need to be careful only to include separator if it is used.
	 */
	anyKnown = FALSE; allKnown = TRUE; use_UTF8 = FALSE; use_Bytes = FALSE;
	if(nx > 1) {
	    allKnown = sepKnown || sepASCII;
	    anyKnown = sepKnown;
	    use_UTF8 = sepUTF8;
	    use_Bytes = sepBytes;
	}

	pwidth = 0;
	for (j = 0; j < nx; j++) {
	    k = xlength(VECTOR_ELT(x, j));
	    if (k > 0) {
		SEXP cs = STRING_ELT(VECTOR_ELT(x, j), i % k);
		if(IS_UTF8(cs)) use_UTF8 = TRUE;
		if(IS_BYTES(cs)) use_Bytes = TRUE;
	    }
	}
	if (use_Bytes) use_UTF8 = FALSE;
	vmax = vmaxget();
	for (j = 0; j < nx; j++) {
	    k = xlength(VECTOR_ELT(x, j));
	    if (k > 0) {
		if(use_Bytes)
		    pwidth += strlen(CHAR(STRING_ELT(VECTOR_ELT(x, j), i % k)));
		else if(use_UTF8)
		    pwidth += strlen(translateCharUTF8(STRING_ELT(VECTOR_ELT(x, j), i % k)));
		else
		    pwidth += strlen(translateChar(STRING_ELT(VECTOR_ELT(x, j), i % k)));
		vmaxset(vmax);
	    }
	}
	if(use_sep) {
	    if (use_UTF8 && !u_csep) {
		u_csep = translateCharUTF8(sep);
		u_sepw = (int) strlen(u_csep); // will be short
	    }
	    pwidth += (nx - 1) * (use_UTF8 ? u_sepw : sepw);
	}
	if (pwidth > INT_MAX)
	    error(_("result would exceed 2^31-1 bytes"));
	cbuf = buf = R_AllocStringBuffer(pwidth, &cbuff);
	vmax = vmaxget();
	for (j = 0; j < nx; j++) {
	    k = xlength(VECTOR_ELT(x, j));
	    if (k > 0) {
		SEXP cs = STRING_ELT(VECTOR_ELT(x, j), i % k);
		if (use_UTF8) {
		    s = translateCharUTF8(cs);
		    strcpy(buf, s);
		    buf += strlen(s);
		} else {
		    s = use_Bytes ? CHAR(cs) : translateChar(cs);
		    strcpy(buf, s);
		    buf += strlen(s);
		    allKnown = allKnown && (strIsASCII(s) || (ENC_KNOWN(cs)> 0));
		    anyKnown = anyKnown || (ENC_KNOWN(cs)> 0);
		}
	    }
	    if (sepw != 0 && j != nx - 1) {
		if (use_UTF8) {
		    strcpy(buf, u_csep);
		    buf += u_sepw;
		} else {
		    strcpy(buf, csep);
		    buf += sepw;
		}
	    }
	    vmax = vmaxget();
	}
	ienc = 0;
	if(use_UTF8) ienc = CE_UTF8;
	else if(use_Bytes) ienc = CE_BYTES;
	else if(anyKnown && allKnown) {
	    if(known_to_be_latin1) ienc = CE_LATIN1;
	    if(known_to_be_utf8) ienc = CE_UTF8;
	}
	SET_STRING_ELT(ans, i, mkCharCE(cbuf, ienc));
    }

    /* Now collapse, if required. */

    if(collapse != R_NilValue && (nx = XLENGTH(ans)) > 0) {
	sep = STRING_ELT(collapse, 0);
	use_UTF8 = IS_UTF8(sep);
	use_Bytes = IS_BYTES(sep);
	for (i = 0; i < nx; i++) {
	    if(IS_UTF8(STRING_ELT(ans, i))) use_UTF8 = TRUE;
	    if(IS_BYTES(STRING_ELT(ans, i))) use_Bytes = TRUE;
	}
	if(use_Bytes) {
	    csep = CHAR(sep);
	    use_UTF8 = FALSE;
	} else if(use_UTF8)
	    csep = translateCharUTF8(sep);
	else
	    csep = translateChar(sep);
	sepw = (int) strlen(csep);
	anyKnown = ENC_KNOWN(sep) > 0;
	allKnown = anyKnown || strIsASCII(csep);
	pwidth = 0;
	vmax = vmaxget();
	for (i = 0; i < nx; i++)
	    if(use_UTF8) {
		pwidth += strlen(translateCharUTF8(STRING_ELT(ans, i)));
		vmaxset(vmax);
	    } else /* already translated */
		pwidth += strlen(CHAR(STRING_ELT(ans, i)));
	pwidth += (nx - 1) * sepw;
	if (pwidth > INT_MAX)
	    error(_("result would exceed 2^31-1 bytes"));
	cbuf = buf = R_AllocStringBuffer(pwidth, &cbuff);
	vmax = vmaxget();
	for (i = 0; i < nx; i++) {
	    if(i > 0) {
		strcpy(buf, csep);
		buf += sepw;
	    }
	    if(use_UTF8)
		s = translateCharUTF8(STRING_ELT(ans, i));
	    else /* already translated */
		s = CHAR(STRING_ELT(ans, i));
	    strcpy(buf, s);
	    while (*buf)
		buf++;
	    allKnown = allKnown &&
		(strIsASCII(s) || (ENC_KNOWN(STRING_ELT(ans, i)) > 0));
	    anyKnown = anyKnown || (ENC_KNOWN(STRING_ELT(ans, i)) > 0);
	    if(use_UTF8) vmaxset(vmax);
	}
	UNPROTECT(1);
	ienc = CE_NATIVE;
	if(use_UTF8) ienc = CE_UTF8;
	else if(use_Bytes) ienc = CE_BYTES;
	else if(anyKnown && allKnown) {
	    if(known_to_be_latin1) ienc = CE_LATIN1;
	    if(known_to_be_utf8) ienc = CE_UTF8;
	}
	PROTECT(ans = allocVector(STRSXP, 1));
	SET_STRING_ELT(ans, 0, mkCharCE(cbuf, ienc));
    }
    R_FreeStringBufferL(&cbuff);
    UNPROTECT(1);
    return ans;
}
Пример #9
0
SEXP attribute_hidden do_formatinfo(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP x;
    int digits, nsmall, no = 1, w, d, e, wi, di, ei;

    checkArity(op, args);
    x = CAR(args);
    R_xlen_t n = XLENGTH(x);
    PrintDefaults();

    digits = asInteger(CADR(args));
    if (!isNull(CADR(args))) {
	digits = asInteger(CADR(args));
	if (digits == NA_INTEGER || digits < R_MIN_DIGITS_OPT
	    || digits > R_MAX_DIGITS_OPT)
	    error(_("invalid '%s' argument"), "digits");
	R_print.digits = digits;
    }
    nsmall = asInteger(CADDR(args));
    if (nsmall == NA_INTEGER || nsmall < 0 || nsmall > 20)
	error(_("invalid '%s' argument"), "nsmall");

    w = 0;
    d = 0;
    e = 0;
    switch (TYPEOF(x)) {

    case RAWSXP:
	formatRaw(RAW(x), n, &w);
	break;

    case LGLSXP:
	formatLogical(LOGICAL(x), n, &w);
	break;

    case INTSXP:
	formatInteger(INTEGER(x), n, &w);
	break;

    case REALSXP:
	no = 3;
	formatReal(REAL(x), n, &w, &d, &e, nsmall);
	break;

    case CPLXSXP:
	no = 6;
	wi = di = ei = 0;
	formatComplex(COMPLEX(x), n, &w, &d, &e, &wi, &di, &ei, nsmall);
	break;

    case STRSXP:
	for (R_xlen_t i = 0; i < n; i++)
	    if (STRING_ELT(x, i) != NA_STRING) {
		int il = Rstrlen(STRING_ELT(x, i), 0);
		if (il > w) w = il;
	    }
	break;

    default:
	error(_("atomic vector arguments only"));
    }
    x = allocVector(INTSXP, no);
    INTEGER(x)[0] = w;
    if(no > 1) {
	INTEGER(x)[1] = d;
	INTEGER(x)[2] = e;
    }
    if(no > 3) {
	INTEGER(x)[3] = wi;
	INTEGER(x)[4] = di;
	INTEGER(x)[5] = ei;
    }
    return x;
}
Пример #10
0
SEXP attribute_hidden do_filepath(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP ans, sep, x;
    int i, j, k, ln, maxlen, nx, nzero, pwidth, sepw;
    const char *s, *csep, *cbuf;
    char *buf;

    checkArity(op, args);

    /* Check the arguments */

    x = CAR(args);
    if (!isVectorList(x))
	error(_("invalid first argument"));
    nx = length(x);
    if(nx == 0) return allocVector(STRSXP, 0);


    sep = CADR(args);
    if (!isString(sep) || LENGTH(sep) <= 0 || STRING_ELT(sep, 0) == NA_STRING)
	error(_("invalid separator"));
    sep = STRING_ELT(sep, 0);
    csep = CHAR(sep);
    sepw = (int) strlen(csep); /* hopefully 1 */

    /* Any zero-length argument gives zero-length result */
    maxlen = 0; nzero = 0;
    for (j = 0; j < nx; j++) {
	if (!isString(VECTOR_ELT(x, j))) {
	    /* formerly in R code: moved to C for speed */
	    SEXP call, xj = VECTOR_ELT(x, j);
	    if(OBJECT(xj)) { /* method dispatch */
		PROTECT(call = lang2(install("as.character"), xj));
		SET_VECTOR_ELT(x, j, eval(call, env));
		UNPROTECT(1);
	    } else if (isSymbol(xj))
		SET_VECTOR_ELT(x, j, ScalarString(PRINTNAME(xj)));
	    else
		SET_VECTOR_ELT(x, j, coerceVector(xj, STRSXP));

	    if (!isString(VECTOR_ELT(x, j)))
		error(_("non-string argument to Internal paste"));
	}
	ln = length(VECTOR_ELT(x, j));
	if(ln > maxlen) maxlen = ln;
	if(ln == 0) {nzero++; break;}
    }
    if(nzero || maxlen == 0) return allocVector(STRSXP, 0);

    PROTECT(ans = allocVector(STRSXP, maxlen));

    for (i = 0; i < maxlen; i++) {
	pwidth = 0;
	for (j = 0; j < nx; j++) {
	    k = length(VECTOR_ELT(x, j));
	    pwidth += (int) strlen(translateChar(STRING_ELT(VECTOR_ELT(x, j), i % k)));
	}
	pwidth += (nx - 1) * sepw;
	cbuf = buf = R_AllocStringBuffer(pwidth, &cbuff);
	for (j = 0; j < nx; j++) {
	    k = length(VECTOR_ELT(x, j));
	    if (k > 0) {
		s = translateChar(STRING_ELT(VECTOR_ELT(x, j), i % k));
		strcpy(buf, s);
		buf += strlen(s);
	    }
	    if (j != nx - 1 && sepw != 0) {
		strcpy(buf, csep);
		buf += sepw;
	    }
	}
#ifdef Win32
	// Trailing seps are invalid for file paths except for / and d:/
	if(streql(csep, "/") || streql(csep, "\\")) {
	    if(buf > cbuf) {
		buf--;
		if(*buf == csep[0] && buf > cbuf &&
		   (buf != cbuf+2 || cbuf[1] != ':')) *buf = '\0';
	    }
	}
#endif
	SET_STRING_ELT(ans, i, mkChar(cbuf));
    }
    R_FreeStringBufferL(&cbuff);
    UNPROTECT(1);
    return ans;
}
Пример #11
0
/* format.default(x, trim, digits, nsmall, width, justify, na.encode,
		  scientific) */
SEXP attribute_hidden do_format(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP l, x, y, swd;
    int il, digits, trim = 0, nsmall = 0, wd = 0, adj = -1, na, sci = 0;
    int w, d, e;
    int wi, di, ei, scikeep;
    const char *strp;
    R_xlen_t i, n;

    checkArity(op, args);
    PrintDefaults();
    scikeep = R_print.scipen;

    if (isEnvironment(x = CAR(args))) {
	return mkString(EncodeEnvironment(x));
    }
    else if (!isVector(x))
	error(_("first argument must be atomic"));
    args = CDR(args);

    trim = asLogical(CAR(args));
    if (trim == NA_INTEGER)
	error(_("invalid '%s' argument"), "trim");
    args = CDR(args);

    if (!isNull(CAR(args))) {
	digits = asInteger(CAR(args));
	if (digits == NA_INTEGER || digits < R_MIN_DIGITS_OPT
	    || digits > R_MAX_DIGITS_OPT)
	    error(_("invalid '%s' argument"), "digits");
	R_print.digits = digits;
    }
    args = CDR(args);

    nsmall = asInteger(CAR(args));
    if (nsmall == NA_INTEGER || nsmall < 0 || nsmall > 20)
	error(_("invalid '%s' argument"), "nsmall");
    args = CDR(args);

    if (isNull(swd = CAR(args))) wd = 0; else wd = asInteger(swd);
    if(wd == NA_INTEGER)
	error(_("invalid '%s' argument"), "width");
    args = CDR(args);

    adj = asInteger(CAR(args));
    if(adj == NA_INTEGER || adj < 0 || adj > 3)
	error(_("invalid '%s' argument"), "justify");
    args = CDR(args);

    na = asLogical(CAR(args));
    if(na == NA_LOGICAL)
	error(_("invalid '%s' argument"), "na.encode");
    args = CDR(args);
    if(LENGTH(CAR(args)) != 1)
	error(_("invalid '%s' argument"), "scientific");
    if(isLogical(CAR(args))) {
	int tmp = LOGICAL(CAR(args))[0];
	if(tmp == NA_LOGICAL) sci = NA_INTEGER;
	else sci = tmp > 0 ?-100 : 100;
    } else if (isNumeric(CAR(args))) {
	sci = asInteger(CAR(args));
    } else
	error(_("invalid '%s' argument"), "scientific");
    if(sci != NA_INTEGER) R_print.scipen = sci;

    if ((n = XLENGTH(x)) <= 0) {
	PROTECT(y = allocVector(STRSXP, 0));
    } else {
	switch (TYPEOF(x)) {

	case LGLSXP:
	    PROTECT(y = allocVector(STRSXP, n));
	    if (trim) w = 0; else formatLogical(LOGICAL(x), n, &w);
	    w = imax2(w, wd);
	    for (i = 0; i < n; i++) {
		strp = EncodeLogical(LOGICAL(x)[i], w);
		SET_STRING_ELT(y, i, mkChar(strp));
	    }
	    break;

	case INTSXP:
	    PROTECT(y = allocVector(STRSXP, n));
	    if (trim) w = 0;
	    else formatInteger(INTEGER(x), n, &w);
	    w = imax2(w, wd);
	    for (i = 0; i < n; i++) {
		strp = EncodeInteger(INTEGER(x)[i], w);
		SET_STRING_ELT(y, i, mkChar(strp));
	    }
	    break;

	case REALSXP:
	    formatReal(REAL(x), n, &w, &d, &e, nsmall);
	    if (trim) w = 0;
	    w = imax2(w, wd);
	    PROTECT(y = allocVector(STRSXP, n));
	    for (i = 0; i < n; i++) {
		strp = EncodeReal0(REAL(x)[i], w, d, e, OutDec);
		SET_STRING_ELT(y, i, mkChar(strp));
	    }
	    break;

	case CPLXSXP:
	    formatComplex(COMPLEX(x), n, &w, &d, &e, &wi, &di, &ei, nsmall);
	    if (trim) wi = w = 0;
	    w = imax2(w, wd); wi = imax2(wi, wd);
	    PROTECT(y = allocVector(STRSXP, n));
	    for (i = 0; i < n; i++) {
		strp = EncodeComplex(COMPLEX(x)[i], w, d, e, wi, di, ei, OutDec);
		SET_STRING_ELT(y, i, mkChar(strp));
	    }
	    break;

	case STRSXP:
	{
	    /* this has to be different from formatString/EncodeString as
	       we don't actually want to encode here */
	    const char *s;
	    char *q;
	    int b, b0, cnt = 0, j;
	    SEXP s0, xx;

	    /* This is clumsy, but it saves rewriting and re-testing
	       this complex code */
	    PROTECT(xx = duplicate(x));
	    for (i = 0; i < n; i++) {
		SEXP tmp =  STRING_ELT(xx, i);
		if(IS_BYTES(tmp)) {
		    const char *p = CHAR(tmp), *q;
		    char *pp = R_alloc(4*strlen(p)+1, 1), *qq = pp, buf[5];
		    for (q = p; *q; q++) {
			unsigned char k = (unsigned char) *q;
			if (k >= 0x20 && k < 0x80) {
			    *qq++ = *q;
			} else {
			    snprintf(buf, 5, "\\x%02x", k);
			    for(int j = 0; j < 4; j++) *qq++ = buf[j];
			}
		    }
		    *qq = '\0';
		    s = pp;
		} else s = translateChar(tmp);
		if(s != CHAR(tmp)) SET_STRING_ELT(xx, i, mkChar(s));
	    }

	    w = wd;
	    if (adj != Rprt_adj_none) {
		for (i = 0; i < n; i++)
		    if (STRING_ELT(xx, i) != NA_STRING)
			w = imax2(w, Rstrlen(STRING_ELT(xx, i), 0));
		    else if (na) w = imax2(w, R_print.na_width);
	    } else w = 0;
	    /* now calculate the buffer size needed, in bytes */
	    for (i = 0; i < n; i++)
		if (STRING_ELT(xx, i) != NA_STRING) {
		    il = Rstrlen(STRING_ELT(xx, i), 0);
		    cnt = imax2(cnt, LENGTH(STRING_ELT(xx, i)) + imax2(0, w-il));
		} else if (na) cnt  = imax2(cnt, R_print.na_width + imax2(0, w-R_print.na_width));
	    R_CheckStack2(cnt+1);
	    char buff[cnt+1];
	    PROTECT(y = allocVector(STRSXP, n));
	    for (i = 0; i < n; i++) {
		if(!na && STRING_ELT(xx, i) == NA_STRING) {
		    SET_STRING_ELT(y, i, NA_STRING);
		} else {
		    q = buff;
		    if(STRING_ELT(xx, i) == NA_STRING) s0 = R_print.na_string;
		    else s0 = STRING_ELT(xx, i) ;
		    s = CHAR(s0);
		    il = Rstrlen(s0, 0);
		    b = w - il;
		    if(b > 0 && adj != Rprt_adj_left) {
			b0 = (adj == Rprt_adj_centre) ? b/2 : b;
			for(j = 0 ; j < b0 ; j++) *q++ = ' ';
			b -= b0;
		    }
		    for(j = 0; j < LENGTH(s0); j++) *q++ = *s++;
		    if(b > 0 && adj != Rprt_adj_right)
			for(j = 0 ; j < b ; j++) *q++ = ' ';
		    *q = '\0';
		    SET_STRING_ELT(y, i, mkChar(buff));
		}
	    }
	}
	UNPROTECT(2); /* xx , y */
	PROTECT(y);
	break;
	default:
	    error(_("Impossible mode ( x )")); y = R_NilValue;/* -Wall */
	}
    }
    if((l = getAttrib(x, R_DimSymbol)) != R_NilValue) {
	setAttrib(y, R_DimSymbol, l);
	if((l = getAttrib(x, R_DimNamesSymbol)) != R_NilValue)
	    setAttrib(y, R_DimNamesSymbol, l);
    } else if((l = getAttrib(x, R_NamesSymbol)) != R_NilValue)
	setAttrib(y, R_NamesSymbol, l);

    /* In case something else forgets to set PrintDefaults(), PR#14477 */
    R_print.scipen = scikeep;

    UNPROTECT(1); /* y */
    return y;
}
Пример #12
0
SEXP MlomarC(SEXP y, SEXP n, SEXP d, SEXP calb, SEXP morder, SEXP span, SEXP cnst, SEXP ns)
{
    double *d1,*d2,*d3,*d4,*d5,*d6,*d7,*d8,*d9;
    int *i1,*i2,*i3,*i4,*i5,*i6,*i7,*i8,*i9,*i10,*i11,*i12,*i13,*i14;

    SEXP ans =  R_NilValue, mean = R_NilValue, var = R_NilValue, ld1 = R_NilValue, ld2 = R_NilValue;
    SEXP ms = R_NilValue, aicm = R_NilValue, mp = R_NilValue, aicc = R_NilValue, mf = R_NilValue, aic = R_NilValue,  a = R_NilValue,  e = R_NilValue,  ks = R_NilValue, ke = R_NilValue, nns = R_NilValue;

    double *xmean, *xvar, *xaicm, *xaicc, *xaic, *xa, *xe = NULL;
    int    *xld1, *xld2, *xms, *xmp , *xmf, *xks, *xke, *xnns = NULL;
    int    i, nd, mo, ns0, k;

    d1 = NUMERIC_POINTER(y);
    i1 = INTEGER_POINTER(n);
    i2 = INTEGER_POINTER(d);
    d2 = NUMERIC_POINTER(calb);
    i3 = INTEGER_POINTER(morder);
    i4 = INTEGER_POINTER(span);
    i5 = INTEGER_POINTER(cnst);
    i6 = INTEGER_POINTER(ns);

    nd = *i2;
    mo = *i3;
    ns0 = *i6;
    k = nd*nd*ns0;
    PROTECT(ans = allocVector(VECSXP, 15));
    SET_VECTOR_ELT(ans, 0, mean = allocVector(REALSXP, nd));
    SET_VECTOR_ELT(ans, 1, var = allocVector(REALSXP, nd));
    SET_VECTOR_ELT(ans, 2, ld1 = allocVector(INTSXP, ns0));
    SET_VECTOR_ELT(ans, 3, ld2 = allocVector(INTSXP, ns0));
    SET_VECTOR_ELT(ans, 4, ms = allocVector(INTSXP, ns0));
    SET_VECTOR_ELT(ans, 5, aicm = allocVector(REALSXP, ns0)); 
    SET_VECTOR_ELT(ans, 6, mp = allocVector(INTSXP, ns0));
    SET_VECTOR_ELT(ans, 7, aicc = allocVector(REALSXP, ns0));
    SET_VECTOR_ELT(ans, 8, mf = allocVector(INTSXP, ns0));
    SET_VECTOR_ELT(ans, 9, aic = allocVector(REALSXP, ns0)); 
    SET_VECTOR_ELT(ans, 10, a = allocVector(REALSXP, k*mo));
    SET_VECTOR_ELT(ans, 11, e = allocVector(REALSXP, k)); 
    SET_VECTOR_ELT(ans, 12, ks = allocVector(INTSXP, ns0));
    SET_VECTOR_ELT(ans, 13, ke = allocVector(INTSXP, ns0));
    SET_VECTOR_ELT(ans, 14, nns = allocVector(INTSXP, 1));

    d3 = NUMERIC_POINTER(mean);
    d4 = NUMERIC_POINTER(var);
    i7 = INTEGER_POINTER(ld1);
    i8 = INTEGER_POINTER(ld2);
    i9 = INTEGER_POINTER(ms);
    d5 = NUMERIC_POINTER(aicm);
    i10 = INTEGER_POINTER(mp);
    d6 = NUMERIC_POINTER(aicc);
    i11 = INTEGER_POINTER(mf);
    d7 = NUMERIC_POINTER(aic);
    d8 = NUMERIC_POINTER(a);
    d9 = NUMERIC_POINTER(e);
    i12 = INTEGER_POINTER(ks);
    i13 = INTEGER_POINTER(ke);
    i14 = INTEGER_POINTER(nns);

    F77_CALL(mlomarf) (d1,i1,i2,d2,i3,i4,i5,i6,d3,d4,i7,i8,i9,d5,i10,d6,i11,d7,d8,d9,i12,i13,i14);

    xmean = REAL(mean);
    xvar = REAL(var);
    xld1 = INTEGER(ld1);
    xld2 = INTEGER(ld2);
    xms = INTEGER(ms);
    xaicm = REAL(aicm);
    xmp = INTEGER(mp);
    xaicc = REAL(aicc);
    xmf = INTEGER(mf);
    xaic = REAL(aic);
    xa = REAL(a);
    xe = REAL(e);
    xks = INTEGER(ks);
    xke = INTEGER(ke);
    xnns = INTEGER(nns);

    *xmean = *d3;
    *xvar = *d4;
    for(i=0; i<nd; i++) xld1[i] = i7[i];
    for(i=0; i<nd; i++) xld2[i] = i8[i];
    for(i=0; i<ns0; i++) xms[i] = i9[i];
    for(i=0; i<ns0; i++) xaicm[i] = d5[i];
    for(i=0; i<ns0; i++) xmp[i] = i10[i];
    for(i=0; i<ns0; i++) xaicc[i] = d6[i];
    for(i=0; i<ns0; i++) xmf[i] = i11[i];
    for(i=0; i<ns0; i++) xaic[i] = d7[i];
    for(i=0; i<k*mo; i++) xa[i] = d8[i];
    for(i=0; i<k; i++) xe[i] = d9[i];
    for(i=0; i<ns0; i++) xks[i] = i12[i];
    for(i=0; i<ns0; i++) xke[i] = i13[i];
    *xnns = *i14;

    UNPROTECT(1);

    return ans;
}
Пример #13
0
SEXP bnstruct_heom_dist( SEXP sexp_vec, SEXP sexp_mat, SEXP sexp_num_var, SEXP sexp_num_var_range )
{
	// inputs
	int i,j;
	int nvar = ncols(sexp_mat);
	int nrow = nrows(sexp_mat);
	double * vec = REAL(sexp_vec);
	double * mat = REAL(sexp_mat);
	int * num_var = INTEGER(sexp_num_var);
	double * num_var_range = REAL(sexp_num_var_range);
		
	// allocate output and copy input
	SEXP result;
	PROTECT( result = allocVector(REALSXP, nrow) );
	double * res = REAL(result);
	for( i = 0; i < nrow; i++ )
		res[i] = 0;
		
	// internal structure
	int num_var_ind[nvar];
	double num_var_range_ind[nvar];
	for( i = 0; i < nvar; i++ )
	{
		num_var_ind[i] = 0;
		num_var_range_ind[i] = 0;
	}

	for( i = 0; i < length(sexp_num_var); i++ )
	{
		num_var_ind[ num_var[i] - 1 ] = 1;
		num_var_range_ind[ num_var[i] - 1 ] = num_var_range[i];
	}
	
	// compute distances
	for( i = 0; i < nvar; i++ )
	{
		if( ISNA(vec[i]) )
			for( j = 0; j < nrow; j++ )
				res[j] += 1;
		
		else if( num_var_ind[i] )
			for( j = 0; j < nrow; j++ )
				if( ISNA(mat[j + i*nrow]) )
					res[j] += 1;
				else
					res[j] += pow( (vec[i] - mat[j + i*nrow]) / num_var_range_ind[i], 2 );
		
		else
			for( j = 0; j < nrow; j++ )
				if( ISNA(mat[j + i*nrow]) )
					res[j] += 1;
				else
					res[j] += ( vec[i] != mat[j + i*nrow] );
	}

	for( i = 0; i < nrow; i++ )
		res[i] = sqrt(res[i]);
	
	UNPROTECT(1);
	return( result );
}
SEXP matrixApply(SEXP result, SEXP data, SEXP margin, SEXP function,
                 int worldRank, int worldSize) {

  SEXP ans, data_size;
  
  MPI_Datatype row_type, column_type;
  MPI_Status status;
  
  int my_start, my_end, N, function_nlines,
    nvectors, offset;
  int local_check = 0, global_check = 0;
  int dimensions[2];

  if (worldRank == MASTER_PROCESS) { 
    data_size = GET_DIM(data);
    
    dimensions[0] = INTEGER_POINTER(data_size)[0];
    dimensions[1] = INTEGER_POINTER(data_size)[1];

    /* function SEXP object is a vector of strings, each element contains
       a single line of the function definition */

    function_nlines = length(function);   
  }

  MPI_Bcast(dimensions, 2, MPI_INT, 0, MPI_COMM_WORLD);
  MPI_Bcast(&function_nlines, 1, MPI_INT, 0, MPI_COMM_WORLD);

  /* margin provides the subscripts which the function will be
     applied over.  "1" indicates rows, "2" indicates columns,
     c(1,2)" indicates rows and columns */

  if(worldRank != MASTER_PROCESS)
    PROTECT(margin = allocVector(INTSXP, 1));

  MPI_Bcast(INTEGER(margin), 1, MPI_INT, 0, MPI_COMM_WORLD);

  /* Matrix dimensions in R are interpreted differen than in C.
     We will refer to R rows and columns ordering, so rows are not alligned
     in memory */

  if (INTEGER(margin)[0] == 1) {
    N = dimensions[0];

    /* define vector type type to handle R rows exchange
       (count, blocklength, stride)*/
    MPI_Type_vector (dimensions[1], 1, dimensions[0], MPI_DOUBLE, &row_type);
    MPI_Type_commit (&row_type);

  } else if (INTEGER(margin)[0] == 2) {
    N = dimensions[1];

    /* define contiguous type to handle R columns exchange */
    MPI_Type_contiguous(dimensions[0], MPI_DOUBLE, &column_type);
    MPI_Type_commit(&column_type);
    
  } else if (INTEGER(margin)[0] == 3) {
    // TODO
    DEBUG("Margin number 3 not yet implemented\n");
    return R_NilValue;
  } else {
    DEBUG("Don't know how to deal with margin number %d\n",
          INTEGER(margin)[0]);
    return R_NilValue;
  }
  
  if(worldRank != MASTER_PROCESS) {
  
    /* Allocate memory for SEXP objects on worker nodes.
       alloc... functions do their own error-checking and
       return if the allocation process will fail. */
    loopDistribute(worldRank, worldSize, N, &my_start, &my_end);
    
    if (INTEGER(margin)[0] == 1)
      PROTECT(data = allocMatrix(REALSXP, my_end-my_start, dimensions[1]));
    if (INTEGER(margin)[0] == 2)
      PROTECT(data = allocMatrix(REALSXP, dimensions[0], my_end-my_start));
              
    PROTECT(function = allocVector(STRSXP, function_nlines));
  }

  if ( (data == NULL) ||  (function == NULL) ) {
      local_check = 1;
  } else {
      local_check = 0;
  }

  /* Check whether memory was successfully allocated on all worker nodes */
  MPI_Allreduce(&local_check, &global_check, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD);

  /*  No need to free memory if allocation fails on one of the workers
      R_alloc will release it after .Call returns to R */
  if ( global_check != 0 ) {
    /* Remove all references from the stack, I'm not sure if this is necessary */
    if(worldRank != MASTER_PROCESS)
      UNPROTECT(3);

    return ScalarInteger(-1);
  }

  /* Distribute data between processes */

  for (int worker_id=1; worker_id<worldSize; worker_id++) {

    if (worldRank == MASTER_PROCESS) {

      /* Calculate expected message length for each worker */
      loopDistribute(worker_id, worldSize, N, &my_start, &my_end);
      nvectors = my_end - my_start;

      /* If we applying over rows, as defined in R, we need to use the MPI vector type
         sending each row as a separate message */
      if (INTEGER(margin)[0] == 1) {
        for(int k=0; k<nvectors; k++) {
          offset = my_start+k;
          MPI_Send(&REAL(data)[offset], 1, row_type, worker_id, 0, MPI_COMM_WORLD);
        }
      }

      /* R defined columns are alligned in memory, single message of build from contiguous
         column_type elemensts is send */
      else if (INTEGER(margin)[0] == 2) {
        offset = my_start*dimensions[0];
        MPI_Send(&REAL(data)[offset], nvectors, column_type, worker_id, 0, MPI_COMM_WORLD);
      }
    }
    else if (worldRank == worker_id) {

      nvectors = my_end - my_start;

      if (INTEGER(margin)[0] == 1) {
        
        for(int k=0; k<nvectors; k++) {
          offset = k*dimensions[1];
          MPI_Recv(&REAL(data)[offset], dimensions[1], MPI_DOUBLE, MASTER_PROCESS, 0, MPI_COMM_WORLD, &status);
        }
      }
      else if (INTEGER(margin)[0] == 2) {
        MPI_Recv(REAL(data), nvectors, column_type, MASTER_PROCESS, 0, MPI_COMM_WORLD, &status);
      }
    }
  }

  /* Redo loop distribution for the Master process */
  if (worldRank == MASTER_PROCESS) {
      loopDistribute(worldRank, worldSize, N, &my_start, &my_end);
  }
    
  /* Bcast function name or definition, cover case when definition is split into
     several lines and stored as a SEXP string vector */
   bcastRFunction(function, function_nlines, worldRank);
  
  /* Response container, Vector of SEXPs, margin determines vector length */
  PROTECT(ans = allocVector(VECSXP, N));

  do_matrixApply(ans, data, margin, function, my_start, my_end, dimensions, worldRank);

  gatherData(result, ans, N, my_start, my_end, worldRank);
  
  if(worldRank != MASTER_PROCESS) {
    UNPROTECT(4);
  } else {
    UNPROTECT(1);
  }

  return result;

}
Пример #15
0
/* used in connections.c */
SEXP xlengthgets(SEXP x, R_xlen_t len)
{
    R_xlen_t lenx, i;
    SEXP rval, names, xnames, t;
    if (!isVector(x) && !isVectorizable(x))
	error(_("cannot set length of non-vector"));
    lenx = xlength(x);
    if (lenx == len)
	return (x);
    PROTECT(rval = allocVector(TYPEOF(x), len));
    PROTECT(xnames = getAttrib(x, R_NamesSymbol));
    if (xnames != R_NilValue)
	names = allocVector(STRSXP, len);
    else names = R_NilValue;	/*- just for -Wall --- should we do this ? */
    switch (TYPEOF(x)) {
    case NILSXP:
	break;
    case LGLSXP:
    case INTSXP:
	for (i = 0; i < len; i++)
	    if (i < lenx) {
		INTEGER(rval)[i] = INTEGER(x)[i];
		if (xnames != R_NilValue)
		    SET_STRING_ELT(names, i, STRING_ELT(xnames, i));
	    }
	    else
		INTEGER(rval)[i] = NA_INTEGER;
	break;
    case REALSXP:
	for (i = 0; i < len; i++)
	    if (i < lenx) {
		REAL(rval)[i] = REAL(x)[i];
		if (xnames != R_NilValue)
		    SET_STRING_ELT(names, i, STRING_ELT(xnames, i));
	    }
	    else
		REAL(rval)[i] = NA_REAL;
	break;
    case CPLXSXP:
	for (i = 0; i < len; i++)
	    if (i < lenx) {
		COMPLEX(rval)[i] = COMPLEX(x)[i];
		if (xnames != R_NilValue)
		    SET_STRING_ELT(names, i, STRING_ELT(xnames, i));
	    }
	    else {
		COMPLEX(rval)[i].r = NA_REAL;
		COMPLEX(rval)[i].i = NA_REAL;
	    }
	break;
    case STRSXP:
	for (i = 0; i < len; i++)
	    if (i < lenx) {
		SET_STRING_ELT(rval, i, STRING_ELT(x, i));
		if (xnames != R_NilValue)
		    SET_STRING_ELT(names, i, STRING_ELT(xnames, i));
	    }
	    else
		SET_STRING_ELT(rval, i, NA_STRING);
	break;
    case LISTSXP:
	for (t = rval; t != R_NilValue; t = CDR(t), x = CDR(x)) {
	    SETCAR(t, CAR(x));
	    SET_TAG(t, TAG(x));
	}
    case VECSXP:
	for (i = 0; i < len; i++)
	    if (i < lenx) {
		SET_VECTOR_ELT(rval, i, VECTOR_ELT(x, i));
		if (xnames != R_NilValue)
		    SET_STRING_ELT(names, i, STRING_ELT(xnames, i));
	    }
	break;
    case RAWSXP:
	for (i = 0; i < len; i++)
	    if (i < lenx) {
		RAW(rval)[i] = RAW(x)[i];
		if (xnames != R_NilValue)
		    SET_STRING_ELT(names, i, STRING_ELT(xnames, i));
	    }
	    else
		RAW(rval)[i] = (Rbyte) 0;
	break;
    default:
	UNIMPLEMENTED_TYPE("length<-", x);
    }
    if (isVector(x) && xnames != R_NilValue)
	setAttrib(rval, R_NamesSymbol, names);
    UNPROTECT(2);
    return rval;
}
Пример #16
0
/* A generic recv wrapper function */
SEXP SOCK_RECV(SEXP S, SEXP EXT, SEXP BS, SEXP MAXBUFSIZE)
{
  SEXP ans = R_NilValue;
  void *buf;
  char *msg, *p;
//  struct pollfd pfds;
  int  j, s = INTEGER(S)[0];
  size_t k = 0;
  double maxbufsize = REAL(MAXBUFSIZE)[0];
  int bufsize = MBUF;
  int bs = INTEGER(BS)[0];
  if(maxbufsize < bs) maxbufsize = bs;
  buf = (void *)malloc(bs);
  msg = (char *)malloc(bs);
  p = msg;
//  pfds.fd = s;
//  pfds.events = POLLIN;
//  h = poll(&pfds, 1, 50);
//  while(h>0) {
  j = 1;
  while(j>=0) {
#ifdef WIN32
    j = recv((SOCKET)s, buf, bs, 0);
#else
    j = recv(s, buf, bs, 0);
#endif
    if(j<1) break;
/* If we exceed the maxbufsize, break. This leaves data
 * in the TCP RX buffer. XXX We need to tell R that this
 * is an incomplete read so this can be handled at a high
 * level, for example by closing the connection or whatever.
 * The code is here for basic protection from DoS and memory
 * overcommit attacks. 
 */
    if(k+j > maxbufsize) break;
    if(k + j > bufsize) {
      bufsize = bufsize + MBUF;
      msg = (char *)realloc(msg, bufsize);  
    }
    p = msg + k;
    memcpy((void *)p, buf, j);
    k = k + j;
//    h=poll(&pfds, 1, 50);
  }
  if(INTEGER(EXT)[0]) {
/* return a pointer to the recv buffer */
    ans = R_MakeExternalPtr ((void *)msg, R_NilValue, R_NilValue);
    R_RegisterCFinalizer (ans, recv_finalize);
    free(buf);
  }
  else {
/* Copy to a raw vector */
    PROTECT(ans=allocVector(RAWSXP,k));
    p = (char *)RAW(ans);
    memcpy((void *)p, (void *)msg, k);
    free(buf);
    free(msg);
    UNPROTECT(1);
  }
  return ans;
}
Пример #17
0
static SEXP baseCallback(GEevent task, pGEDevDesc dd, SEXP data)
{
    GESystemDesc *sd;
    baseSystemState *bss, *bss2;
    SEXP result = R_NilValue;

    switch (task) {
    case GE_FinaliseState:
	/* called from unregisterOne */
	sd = dd->gesd[baseRegisterIndex];
	free(sd->systemSpecific);
	sd->systemSpecific = NULL;
	break;
    case GE_InitState:
    {
	/* called from registerOne */
	pDevDesc dev;
	GPar *ddp;
	sd = dd->gesd[baseRegisterIndex];
	dev = dd->dev;
	bss = sd->systemSpecific = malloc(sizeof(baseSystemState));
        /* Bail out if necessary */
        if (!bss)
            return result;
	ddp = &(bss->dp);
	GInit(ddp);
	/* For some things, the device sets the starting value at least.
	 */
	ddp->ps = dev->startps;
	ddp->col = ddp->fg = dev->startcol;
	ddp->bg = dev->startfill;
	ddp->font = dev->startfont;
	ddp->lty = dev->startlty;
	ddp->gamma = dev->startgamma;
	/* Initialise the gp settings too: formerly in addDevice. */
	copyGPar(ddp, &(bss->gp));
	GReset(dd);
	/*
	 * The device has not yet received any base output
	 */
	bss->baseDevice = FALSE;
        /* Indicate success */
        result = R_BlankString;
	break;
    }
    case GE_CopyState:
    {
	/* called from GEcopyDisplayList */
	pGEDevDesc curdd = GEcurrentDevice();
	bss = dd->gesd[baseRegisterIndex]->systemSpecific;
	bss2 = curdd->gesd[baseRegisterIndex]->systemSpecific;
	copyGPar(&(bss->dpSaved), &(bss2->dpSaved));
	restoredpSaved(curdd);
	copyGPar(&(bss2->dp), &(bss2->gp));
	GReset(curdd);
	break;
    }
    case GE_SaveState:
	/* called from GEinitDisplayList */
	bss = dd->gesd[baseRegisterIndex]->systemSpecific;
	copyGPar(&(bss->dp), &(bss->dpSaved));
	break;
    case GE_RestoreState:
	/* called from GEplayDisplayList */
	bss = dd->gesd[baseRegisterIndex]->systemSpecific;
	restoredpSaved(dd);
	copyGPar(&(bss->dp), &(bss->gp));
	GReset(dd);
	break;
    case GE_SaveSnapshotState:
	/* called from GEcreateSnapshot */
	bss = dd->gesd[baseRegisterIndex]->systemSpecific;
	/* Changed from INTSXP in 2.7.0: but saved graphics lists
	   are protected by an R version number */
	PROTECT(result = allocVector(RAWSXP, sizeof(GPar)));
	copyGPar(&(bss->dpSaved), (GPar*) RAW(result));
	UNPROTECT(1);
	break;
    case GE_RestoreSnapshotState:
	/* called from GEplaySnapshot */
	bss = dd->gesd[baseRegisterIndex]->systemSpecific;
	copyGPar((GPar*) RAW(data), &(bss->dpSaved));
	restoredpSaved(dd);
	copyGPar(&(bss->dp), &(bss->gp));
	GReset(dd);
	break;
    case GE_CheckPlot:
	/* called from GEcheckState:
	   Check that the current plotting state is "valid"
	 */
	bss = dd->gesd[baseRegisterIndex]->systemSpecific;
	result = ScalarLogical(bss->baseDevice ?
			       (bss->gp.state == 1) && bss->gp.valid :
			       TRUE);
	break;
    case GE_ScalePS:
    {
	/* called from GEhandleEvent in devWindows.c */
	GPar *ddp, *ddpSaved;
	bss = dd->gesd[baseRegisterIndex]->systemSpecific;
	ddp = &(bss->dp);
	ddpSaved = &(bss->dpSaved);
	if (isReal(data) && LENGTH(data) == 1) {
	    double rf = REAL(data)[0];
	    ddp->scale *= rf;
	    /* Modify the saved settings so this effects display list too */
	    ddpSaved->scale *= rf;
	} else
	  error("event 'GE_ScalePS' requires a single numeric value");
	break;
    }
    }
    return result;
}
Пример #18
0
SEXP declust(SEXP theta,
             SEXP rbwd,
             SEXP revents,
             SEXP rpoly,
             SEXP tperiod)
{
  SEXP dim, pdim, out, integ0;
  
  // extract events
  PROTECT(dim = allocVector(INTSXP, 2));
  dim = getAttrib(revents, R_DimSymbol);
  int N = INTEGER(dim)[0];
  double *events = REAL(revents);
  double t[N], x[N], y[N], m[N], bk[N], pb[N], lam[N];  
  for (int i = 0; i < N; i++)
    {
      t[i] = events[i];
      x[i] = events[N + i];
      y[i] = events[2 * N + i];
      m[i] = events[3 * N + i];
      bk[i] = events[5 * N + i];
      pb[i] = events[6 * N + i];
      lam[i] = events[7 * N + i];
    }
  
  // extract polygon information
  PROTECT(pdim = allocVector(INTSXP, 2));
  pdim = getAttrib(rpoly, R_DimSymbol);
  int np = INTEGER(pdim)[0];
  double *poly = REAL(rpoly);
  double px[np], py[np];
  for (int i = 0; i < np; i++)
    {
      px[i] = poly[i];
      py[i] = poly[np + i];
    }
  
  // extract time period information
  double *tper = REAL(tperiod);
  double tstart2 = tper[0], tlength = tper[1];

  // extract bandwidthes
  double *bwd = REAL(rbwd);

  // extract model paramters
  double *tht = REAL(theta);

  double s, r0, w[1];

  for (int i = 0; i < N; i++)
    {
      s = 0;
      for (int j = 0; j < N; j++)
	{
	  r0 = dist(x[i], y[i], x[j], y[j]);
	  s += pb[j] * dGauss(r0, bwd[j]);
	}
      bk[i] = s / (tlength - tstart2);
      events[5 * N + i] = bk[i];
    }
 
  s = 0;
  for (int i = 0; i < N; i++)
    {
      w[0] = bwd[i];
      s += pb[i] * polyinteg(pGauss, w, &np, px, py, x[i], y[i]);
      lam[i] = lambdaj(tht,i, t, x, y, m, bk);
      events[6 * N + i] = (tht[0] * tht[0] * bk[i]) / lam[i];
      events[7 * N + i] = lam[i];
    }

  PROTECT(out = allocVector(VECSXP, 2));
  PROTECT(integ0 = allocVector(REALSXP, 1));
  double *integ0P = REAL(integ0);
  integ0P[0] = s;
  SET_VECTOR_ELT(out, 0, revents); 
  SET_VECTOR_ELT(out, 1, integ0);
  UNPROTECT(4);
  return(out);
}
Пример #19
0
SEXP non_duplicates (SEXP x_, SEXP fromLast_) {
  int fromLast = asLogical(fromLast_),
      i, d=0,
      len   = length(x_);
  
  int *x_int;
  double *x_real;

  SEXP duplicates;
  int *duplicates_int;
  PROTECT(duplicates = allocVector(INTSXP, len)); /* possibly resize this */
  duplicates_int = INTEGER(duplicates);

  if(!fromLast) { /* keep first observation */
    duplicates_int[0] = ++d;
    switch(TYPEOF(x_)) {
      case INTSXP:
        x_int = INTEGER(x_);
        for(i=1; i < len-1; i++) {
          if( x_int[i-1] != x_int[i]) {
#ifdef DEBUG
            Rprintf("i=%i:  x[i-1]=%i, x[i]=%i\n",i,x_int[i-1],x_int[i]);
#endif
            duplicates_int[d++] = i+1;
          }
        }      
        break;
      case REALSXP:
        x_real = REAL(x_);
        for(i=1; i < len; i++) {
          /*
          if( x_real[i-1] == x_real[i])
            duplicates_int[d++] = (int)(-1*(i+1));
          */
          if( x_real[i-1] != x_real[i])
            duplicates_int[d++] = i+1;
        }      
        break;
      default:
        error("only numeric types supported");
        break;
    }
  } else {    /* keep last observation  */
    switch(TYPEOF(x_)) {
      case INTSXP:
        x_int = INTEGER(x_);
        for(i=1; i < len; i++) {
          if( x_int[i-1] != x_int[i])
            duplicates_int[d++] = i;
        }      
        break;
      case REALSXP:
        x_real = REAL(x_);
        for(i=1; i < len; i++) {
          if( x_real[i-1] != x_real[i])
            duplicates_int[d++] = i;
        }      
        break;
      default:
        error("only numeric types supported");
        break;
    }
    duplicates_int[d++] = len;
  }
  UNPROTECT(1);
  return(lengthgets(duplicates, d));
}
Пример #20
0
SEXP bicomponents_R(SEXP net, SEXP sn, SEXP sm)
{
  snaNet *g;
  int *parent,*num,*back,*dfn,i,j,n,count,pc=0;
  element *complist,*ep,*ep2,*es;
  SEXP bicomps,bcl,memb,outlist;

  /*Coerce what needs coercin'*/
  //Rprintf("Initial coercion\n");
  PROTECT(sn=coerceVector(sn,INTSXP)); pc++;
  PROTECT(sm=coerceVector(sm,INTSXP)); pc++;
  PROTECT(net=coerceVector(net,REALSXP)); pc++;
  n=INTEGER(sn)[0];

  /*Initialize sna internal network*/
  GetRNGstate();
  g=elMatTosnaNet(REAL(net),INTEGER(sn),INTEGER(sm));

  /*Calculate the sorting stat*/
  parent=(int *)R_alloc(n,sizeof(int));
  num=(int *)R_alloc(n,sizeof(int));
  back=(int *)R_alloc(n,sizeof(int));
  dfn=(int *)R_alloc(1,sizeof(int));
  for(i=0;i<n;i++){
    parent[i]=-1;
    num[i]=0;
    back[i]=n+1;
  }
  *dfn=0;

  /*Initialize the component list*/
  complist=(element *)R_alloc(1,sizeof(element));
  complist->val=0.0;
  complist->next=NULL;
  complist->dp=NULL;

  /*Walk the graph components, finding bicomponents*/
  es=(element *)R_alloc(1,sizeof(element));
  for(i=0;i<n;i++)
    if(num[i]==0){
      es->next=NULL;
      bicomponentRecurse(g,complist,es,parent,num,back,dfn,i);
    }

  /*Transfer information from complist to output vector*/
  //Rprintf("Gathering components...\n");
  count=(int)complist->val;
  PROTECT(outlist=allocVector(VECSXP,2)); pc++;
  PROTECT(bicomps=allocVector(VECSXP,count)); pc++;
  PROTECT(memb=allocVector(INTSXP,n)); pc++;
  for(i=0;i<n;i++)  /*Initialize memberships, since some have none*/
    INTEGER(memb)[i]=-1;
  ep=complist->next;
  for(i=0;i<count;i++){
    PROTECT(bcl=allocVector(INTSXP,(int)ep->val));
    j=0;
    for(ep2=(element *)ep->dp;ep2!=NULL;ep2=ep2->next){
      INTEGER(bcl)[j++]=(int)ep2->val+1;
      INTEGER(memb)[(int)ep2->val]=i+1;
    }
    SET_VECTOR_ELT(bicomps,i,bcl);
    UNPROTECT(1);
    ep=ep->next;
  }
  SET_VECTOR_ELT(outlist,0,bicomps); 
  SET_VECTOR_ELT(outlist,1,memb); 

  /*Unprotect and return*/
  PutRNGstate();
  UNPROTECT(pc);
  return outlist;
}
Пример #21
0
SEXP superSubset(SEXP x, SEXP y, SEXP fuz, SEXP vo, SEXP nec) { 
    int i, j, k, index;
    double *p_x, *p_incovpri, *p_vo, min, max, so = 0.0, sumx_min, sumx_max, sumpmin_min, sumpmin_max, prisum_min, prisum_max, temp1, temp2;
    int xrows, xcols, yrows, *p_y, *p_fuz, *p_nec;
    
    SEXP usage = PROTECT(allocVector(VECSXP, 5));
    SET_VECTOR_ELT(usage, 0, x = coerceVector(x, REALSXP));
    SET_VECTOR_ELT(usage, 1, y = coerceVector(y, INTSXP));
    SET_VECTOR_ELT(usage, 2, fuz = coerceVector(fuz, INTSXP));
    SET_VECTOR_ELT(usage, 3, vo = coerceVector(vo, REALSXP));
    SET_VECTOR_ELT(usage, 4, nec = coerceVector(nec, INTSXP));
    
    xrows = nrows(x);
    yrows = nrows(y);
    xcols = ncols(x);
    
    double copyline[xcols];
    
    p_x = REAL(x);
    p_y = INTEGER(y);
    p_fuz = INTEGER(fuz);
    p_vo = REAL(vo);
    p_nec = INTEGER(nec);
    
    
    // create the list to be returned to R
    SEXP incovpri = PROTECT(allocMatrix(REALSXP, 6, yrows));
    p_incovpri = REAL(incovpri);
    
    
    // sum of the outcome variable
    for (i = 0; i < length(vo); i++) {
        so += p_vo[i];
    }
    
    
    min = 1000;
    max = 0;
    
    for (k = 0; k < yrows; k++) { // loop for every line of the truth table matrix
        
        sumx_min = 0;
        sumx_max = 0;
        sumpmin_min = 0;
        sumpmin_max = 0;
        prisum_min = 0;  
        prisum_max = 0;
        
        for (i = 0; i < xrows; i++) { // loop over every line of the data matrix
            
            for (j = 0; j < xcols; j++) { // loop over each column of the data matrix
                copyline[j] = p_x[i + xrows * j];
                
                index = k + yrows * j;
                
                if (p_fuz[j] == 1) { // for the fuzzy variables, invert those who have the 3k value equal to 1 ("onex3k" in R)
                    if (p_y[index] == 1) {
                        copyline[j] = 1 - copyline[j];
                    }
                }
                else {
                    if (p_y[index] != (copyline[j] + 1)) {
                        copyline[j] = 0;
                    }
                    else {
                        copyline[j] = 1;
                    }
                }
                
                if (p_y[index] != 0) {
                    
                    if (copyline[j] < min) {
                        min = copyline[j];
                    }
                    
                    if (copyline[j] > max) {
                        max = copyline[j];
                    }
                }
                
            } // end of j loop, over columns
            
            sumx_min += min;
            sumx_max += max;
            sumpmin_min += (min < p_vo[i])?min:p_vo[i];
            sumpmin_max += (max < p_vo[i])?max:p_vo[i];
            temp1 = (min < p_vo[i])?min:p_vo[i];
            temp2 = p_nec[0]?(1 - min):(1 - p_vo[i]);
            prisum_min += (temp1 < temp2)?temp1:temp2;
            temp1 = (max < p_vo[i])?max:p_vo[i];
            temp2 = 1 - max;
            prisum_max += (temp1 < temp2)?temp1:temp2;
            
            min = 1000; // re-initialize min and max values
            max = 0;
            
        } // end of i loop
        
        p_incovpri[k*6] = (sumpmin_min == 0 && sumx_min == 0)?0:(sumpmin_min/sumx_min);
        p_incovpri[k*6 + 1] = (sumpmin_min == 0 && so == 0)?0:(sumpmin_min/so);
        p_incovpri[k*6 + 2] = (sumpmin_max == 0 && sumx_max == 0)?0:(sumpmin_max/sumx_max);
        p_incovpri[k*6 + 3] = (sumpmin_max == 0 && so == 0)?0:(sumpmin_max/so);
        
        temp1 = sumpmin_min - prisum_min;
        temp2 = p_nec[0]?so:sumx_min - prisum_min;
        p_incovpri[k*6 + 4] = (temp1 == 0 && temp2 == 0)?0:(temp1/temp2);
        
        temp1 = sumpmin_max - prisum_max;
        temp2 = so - prisum_max;
        p_incovpri[k*6 + 5] = (temp1 == 0 && temp2 == 0)?0:(temp1/temp2);
        
    } // end of k loop
    
    
    UNPROTECT(2);
    
    return(incovpri);
}
Пример #22
0
SEXP cliques_R(SEXP net, SEXP sn, SEXP sm, SEXP stabulatebyvert, SEXP scomembership, SEXP senumerate)
/*Maximal clique enumeration as an R-callable (.Call) function.  net should be an sna edgelist (w/n vertices and m/2 edges), and must be pre-symmetrized.  stabulatebyvert should be 0 if no tabulation is to be performed, or 1 for vertex-level tabulation of clique membership.  scomembership should be 0 for no co-membership tabulation, 1 for aggregate vertex-by-vertex tabulation, and 2 for size-by-vertex-by-vertex tabulation.  Finally, senumerate should be 1 iff the enumerated clique list should be returned.  (The current algorithm enumerates them internally, regardless.  This is b/c I am lazy, and didn't fold all of the tabulation tasks into the recursion process.  Life is hard.)*/
{
  int n,tabulate,comemb,enumerate,*gotcomp,*compmemb,i,j,k,maxcsize,pc=0;
  double *ccount,*pccountvec,*pcocliquevec=NULL;
  snaNet *g;
  slelement *sep,*sep2,*k0;
  element **clist,*ep;
  SEXP smaxcsize,ccountvec,outlist,cliquevec=R_NilValue;
  SEXP temp=R_NilValue,sp=R_NilValue,cocliquevec=R_NilValue;

  /*Coerce what needs coercin'*/
  PROTECT(sn=coerceVector(sn,INTSXP)); pc++;
  PROTECT(net=coerceVector(net,REALSXP)); pc++;
  PROTECT(stabulatebyvert=coerceVector(stabulatebyvert,INTSXP)); pc++;
  PROTECT(scomembership=coerceVector(scomembership,INTSXP)); pc++;
  PROTECT(senumerate=coerceVector(senumerate,INTSXP)); pc++;
  n=INTEGER(sn)[0];
  tabulate=INTEGER(stabulatebyvert)[0];
  comemb=INTEGER(scomembership)[0];
  enumerate=INTEGER(senumerate)[0];

  /*Pre-allocate what needs pre-allocatin'*/
  ccount=(double *)R_alloc(n,sizeof(double));
  PROTECT(smaxcsize=allocVector(INTSXP,1)); pc++;
  clist=(element **)R_alloc(n,sizeof(element *));
  for(i=0;i<n;i++){
    ccount[i]=0.0;
    clist[i]=NULL;
  }
    
  /*Initialize sna internal network*/
  GetRNGstate();
  g=elMatTosnaNet(REAL(net),INTEGER(sn),INTEGER(sm));

  /*Calculate the components of g*/
  compmemb=undirComponents(g);

  /*Accumulate cliques across components*/
  gotcomp=(int *)R_alloc(compmemb[0],sizeof(int));
  for(i=0;i<compmemb[0];i++)
    gotcomp[i]=0;
  for(i=0;i<n;i++)                   /*Move through vertices in order*/
    if(!gotcomp[compmemb[i+1]-1]){   /*Take first vertex of each component*/
      gotcomp[compmemb[i+1]-1]++;              /*Mark component as visited*/
      /*Get the first maximal clique in this component*/
      k0=slistInsert(NULL,(double)i,NULL);
      k0=cliqueFirstChild(g,k0);
      /*Recursively enumerate all cliques within the component*/
      cliqueRecurse(g,k0,i,clist,ccount,compmemb);
    }
  PutRNGstate();
  
  /*Find the maximum clique size (to cut down on subsequent memory usage)*/
  INTEGER(smaxcsize)[0]=n+1;
  for(i=n-1;(i>=0)&(INTEGER(smaxcsize)[0]==n+1);i--)
    if(ccount[i]>0.0)
      INTEGER(smaxcsize)[0]=i+1;
  maxcsize=INTEGER(smaxcsize)[0];

  /*Allocate memory for R return value objects*/
  if(tabulate){
    PROTECT(ccountvec=allocVector(REALSXP,maxcsize*(1+n))); pc++;
    for(i=0;i<maxcsize*(1+n);i++)
      REAL(ccountvec)[i]=0.0;
  }else{
    PROTECT(ccountvec=allocVector(REALSXP,maxcsize)); pc++;
    for(i=0;i<maxcsize;i++)
      REAL(ccountvec)[i]=0.0;
  }
  pccountvec=REAL(ccountvec);
  switch(comemb){
    case 0:
      cocliquevec=R_NilValue;
      pcocliquevec=NULL;
      break;
    case 1:
      PROTECT(cocliquevec=allocVector(REALSXP,n*n)); pc++;
      for(i=0;i<n*n;i++)
        REAL(cocliquevec)[i]=0.0;
      pcocliquevec=REAL(cocliquevec);
      break;
    case 2:
      PROTECT(cocliquevec=allocVector(REALSXP,maxcsize*n*n)); pc++;
      for(i=0;i<maxcsize*n*n;i++)
        REAL(cocliquevec)[i]=0.0;
      pcocliquevec=REAL(cocliquevec);
      break;
  }
  if(enumerate){
    PROTECT(cliquevec=allocVector(VECSXP,maxcsize)); pc++;
    for(i=0;i<maxcsize;i++){
      if(ccount[i]==0.0)
        SET_VECTOR_ELT(cliquevec,i,R_NilValue);
      else{
        PROTECT(temp=allocVector(VECSXP,(int)(ccount[i])));
        SET_VECTOR_ELT(cliquevec,i,temp);
        UNPROTECT(1);
      }
    }
  }

  /*Tabulate, enumerate, and other good things*/
  for(i=0;i<maxcsize;i++){
    pccountvec[i+tabulate*maxcsize*n]=ccount[i];
    if(ccount[i]>0.0){
      if(enumerate)
        sp=VECTOR_ELT(cliquevec,i);
      /*Walk through every clique of size i+1*/
      for(j=0,ep=clist[i];ep!=NULL;ep=ep->next){
        if(enumerate)
          PROTECT(temp=allocVector(INTSXP,i+1));
        /*Walk through every clique member*/
        for(k=0,sep=((slelement *)(ep->dp))->next[0];sep!=NULL; sep=sep->next[0]){
          if(enumerate)        /*Add to enumeration list*/
            INTEGER(temp)[k++]=(int)(sep->val)+1;
          if(tabulate)         /*Add to vertex-by-size tabulation*/
            pccountvec[i+maxcsize*((int)(sep->val))]++;
          switch(comemb){      /*Add co-membership information*/
            case 0:                /*Case 0 - do nothing*/
              break;
            case 1:                /*Case 1 - just co-membership*/
              for(sep2=((slelement *)(ep->dp))->next[0];sep2!=sep; sep2=sep2->next[0]){
                pcocliquevec[((int)(sep->val))+n*((int)(sep2->val))]++;
                pcocliquevec[((int)(sep2->val))+n*((int)(sep->val))]++;
              }
              pcocliquevec[((int)(sep->val))+n*((int)(sep->val))]++;
              break;
            case 2:                /*Case 2 - co-membership by size*/
              for(sep2=((slelement *)(ep->dp))->next[0];sep2!=sep; sep2=sep2->next[0]){
                pcocliquevec[i+maxcsize*((int)(sep->val))+ maxcsize*n*((int)(sep2->val))]++;
                pcocliquevec[i+maxcsize*((int)(sep2->val))+ maxcsize*n*((int)(sep->val))]++;
              }
              pcocliquevec[i+maxcsize*((int)(sep->val))+ maxcsize*n*((int)(sep->val))]++;
              break;
          }
        }
        if(enumerate){
          SET_VECTOR_ELT(sp,j++,temp);
          UNPROTECT(1);
        }
      }
    }
  }
  
  /*Prepare and return the results*/
  PROTECT(outlist=allocVector(VECSXP,4)); pc++;
  SET_VECTOR_ELT(outlist,0,smaxcsize);
  SET_VECTOR_ELT(outlist,1,ccountvec);
  SET_VECTOR_ELT(outlist,2,cocliquevec);
  SET_VECTOR_ELT(outlist,3,cliquevec);
  UNPROTECT(pc);
  return outlist;
}
Пример #23
0
Файл: objects.c Проект: cran/SMC
/*
 * The following returns a R list with the following components:
 * currentStreams
 * currentLogWeights
 * propUniqueStreamIds
 */
static SEXP
resamp_func_builtin_PPW (Sampler *ss, int currentPeriod, SEXP currentStreams,
                         SEXP currentLogWeights)
{
        ResampleContext *rc = ss->scratch_RC;
        int nspr = ss->nStreamsPreResamp, dpp = ss->dimPerPeriod;
        int ns = ss->nStreams, *sids = rc->streamIds, ii, jj, kk;
        int nusids, *usids = rc->uniqueStreamIds;
        int nComps = 0, nProtected = 0;
        double *ps = rc->partialSum;
        double sum, uu;
        SEXP resampCurrentStreams, resampCurrentLogWeights, resampPropUniqueStreamIds;
        SEXP retList, names;
        double *rcs, *rclw;
        double *scs  = REAL(currentStreams);
        double *sclw = REAL(currentLogWeights);
        double *scaw = REAL(ss->SEXPCurrentAdjWeights);
        void *vmax = vmaxget( );

        PROTECT(resampCurrentStreams    = allocMatrix(REALSXP, ns, dpp));
        ++nComps; ++nProtected;
        PROTECT(resampCurrentLogWeights = allocVector(REALSXP, ns));
        ++nComps; ++nProtected;
        rcs  = REAL(resampCurrentStreams);
        rclw = REAL(resampCurrentLogWeights);

        sampler_adjust_log_weights(nspr, sclw, scaw);
        ps[0] = scaw[0];
        for (jj = 1; jj < nspr; ++jj) {
                ps[jj] = ps[jj - 1] + scaw[jj];
        }
        sum = ps[nspr - 1]; nusids = 0;
        /* resample the streams with probability proportional to their
         * weights */
        for (jj = 0; jj < ns; ++jj) {
                uu = runif(0, sum);
                for (ii = 0; ii < nspr; ++ii) {
                        if (uu <= ps[ii]) { sids[jj] = ii; break; }
                }
                /* copying the resampled stream */
                for (kk = 0; kk < dpp; ++kk)
                        rcs[kk * ns + jj] = scs[kk * nspr + sids[jj]];
                /* making the resampled logWeights = 0 */
                rclw[jj] = 0;
                /* find the unique stream and register it */
                if (utils_is_int_in_iarray(sids[jj], nusids, usids) == FALSE) {
                        usids[nusids] = sids[jj]; ++nusids;
                }
        }
        rc->nUniqueStreamIds    = nusids;
        rc->propUniqueStreamIds = nusids / ((double) nspr);
        PROTECT(resampPropUniqueStreamIds = allocVector(REALSXP, 1));
        ++nComps; ++nProtected;
        REAL(resampPropUniqueStreamIds)[0] = rc->propUniqueStreamIds;

        PROTECT(retList = allocVector(VECSXP, nComps)); ++nProtected;
        PROTECT(names   = allocVector(STRSXP, nComps)); ++nProtected;
        nComps = 0;
        SET_VECTOR_ELT(retList, nComps, resampCurrentStreams);
        SET_STRING_ELT(names,   nComps, mkChar("currentStreams"));
        ++nComps;
        SET_VECTOR_ELT(retList, nComps, resampCurrentLogWeights);
        SET_STRING_ELT(names,   nComps, mkChar("currentLogWeights"));
        ++nComps;
        SET_VECTOR_ELT(retList, nComps, resampPropUniqueStreamIds);
        SET_STRING_ELT(names,   nComps, mkChar("propUniqueStreamIds"));
        setAttrib(retList, R_NamesSymbol, names);
        UNPROTECT(nProtected);
        vmaxset(vmax);
        return retList;        
}
Пример #24
0
SEXP attribute_hidden do_nchar(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP d, s, x, stype;
    R_xlen_t i, len;
    int allowNA;
    size_t ntype;
    int nc;
    const char *type;
    const char *xi;
    wchar_t *wc;
    const void *vmax;

    checkArity(op, args);
    if (isFactor(CAR(args)))
	error(_("'%s' requires a character vector"), "nchar()");
    PROTECT(x = coerceVector(CAR(args), STRSXP));
    if (!isString(x))
	error(_("'%s' requires a character vector"), "nchar()");
    len = XLENGTH(x);
    stype = CADR(args);
    if (!isString(stype) || LENGTH(stype) != 1)
	error(_("invalid '%s' argument"), "type");
    type = CHAR(STRING_ELT(stype, 0)); /* always ASCII */
    ntype = strlen(type);
    if (ntype == 0) error(_("invalid '%s' argument"), "type");
    allowNA = asLogical(CADDR(args));
    if (allowNA == NA_LOGICAL) allowNA = 0;

    PROTECT(s = allocVector(INTSXP, len));
    vmax = vmaxget();
    for (i = 0; i < len; i++) {
	SEXP sxi = STRING_ELT(x, i);
	if (sxi == NA_STRING) {
	    INTEGER(s)[i] = 2;
	    continue;
	}
	if (strncmp(type, "bytes", ntype) == 0) {
	    INTEGER(s)[i] = LENGTH(sxi);
	} else if (strncmp(type, "chars", ntype) == 0) {
	    if (IS_UTF8(sxi)) { /* assume this is valid */
		const char *p = CHAR(sxi);
		nc = 0;
		for( ; *p; p += utf8clen(*p)) nc++;
		INTEGER(s)[i] = nc;
	    } else if (IS_BYTES(sxi)) {
		if (!allowNA) /* could do chars 0 */
		    error(_("number of characters is not computable for element %d in \"bytes\" encoding"), i+1);
		INTEGER(s)[i] = NA_INTEGER;
	    } else if (mbcslocale) {
		nc = (int) mbstowcs(NULL, translateChar(sxi), 0);
		if (!allowNA && nc < 0)
		    error(_("invalid multibyte string %d"), i+1);
		INTEGER(s)[i] = nc >= 0 ? nc : NA_INTEGER;
	    } else
		INTEGER(s)[i] = (int) strlen(translateChar(sxi));
	} else if (strncmp(type, "width", ntype) == 0) {
	    if (IS_UTF8(sxi)) { /* assume this is valid */
		const char *p = CHAR(sxi);
		wchar_t wc1;
		nc = 0;
		for( ; *p; p += utf8clen(*p)) {
		    utf8toucs(&wc1, p);
		    nc += Ri18n_wcwidth(wc1);
		}
		INTEGER(s)[i] = nc;
	    } else if (IS_BYTES(sxi)) {
		if (!allowNA) /* could do width 0 */
		    error(_("width is not computable for element %d in \"bytes\" encoding"), i+1);
		INTEGER(s)[i] = NA_INTEGER;
	    } else if (mbcslocale) {
		xi = translateChar(sxi);
		nc = (int) mbstowcs(NULL, xi, 0);
		if (nc >= 0) {
		    wc = (wchar_t *) R_AllocStringBuffer((nc+1)*sizeof(wchar_t), &cbuff);

		    mbstowcs(wc, xi, nc + 1);
		    INTEGER(s)[i] = Ri18n_wcswidth(wc, 2147483647);
		    if (INTEGER(s)[i] < 1) INTEGER(s)[i] = nc;
		} else if (allowNA)
		    error(_("invalid multibyte string %d"), i+1);
		else
		    INTEGER(s)[i] = NA_INTEGER;
	    } else
		INTEGER(s)[i] = (int) strlen(translateChar(sxi));
	} else
	    error(_("invalid '%s' argument"), "type");
	vmaxset(vmax);
    }
    R_FreeStringBufferL(&cbuff);
    if ((d = getAttrib(x, R_NamesSymbol)) != R_NilValue)
	setAttrib(s, R_NamesSymbol, d);
    if ((d = getAttrib(x, R_DimSymbol)) != R_NilValue)
	setAttrib(s, R_DimSymbol, d);
    if ((d = getAttrib(x, R_DimNamesSymbol)) != R_NilValue)
	setAttrib(s, R_DimNamesSymbol, d);
    UNPROTECT(2);
    return s;
}
Пример #25
0
SEXP mat_split(SEXP s, SEXP sSep, SEXP sNamesSep, SEXP sResilient, SEXP sNcol,
               SEXP sWhat, SEXP sSkip, SEXP sNlines) {
  unsigned int ncol = 1, nrow, np = 0, i, N, resilient = asInteger(sResilient);
  int use_ncol = asInteger(sNcol);
  int nsep = -1;
  int skip = INTEGER(sSkip)[0];
  int nlines = INTEGER(sNlines)[0];
  int len;
  SEXP res, rnam, zerochar = 0;
  char sep;
  char num_buf[48];
  double * res_ptr;
  const char *c, *sraw, *send, *l, *le;;

  /* parse sep input */
  if (TYPEOF(sNamesSep) == STRSXP && LENGTH(sNamesSep) > 0)
    nsep = (int) (unsigned char) *CHAR(STRING_ELT(sNamesSep, 0));
  if (TYPEOF(sSep) != STRSXP || LENGTH(sSep) < 1)
    Rf_error("invalid separator");
  sep = CHAR(STRING_ELT(sSep, 0))[0];

  /* check the input data */
  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) {
      nrow = nrow - skip;
      for (i = 0; i < skip; i++) sraw = memchr(sraw,'\n',XLENGTH(s)) + 1;
    } else {
      nrow = 0;
      sraw = send;
    }
  } else if (TYPEOF(s) == STRSXP) {
    nrow = LENGTH(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;

  /* If no rows left, return an empty matrix */
  if (!nrow) {
    if (np) UNPROTECT(np);
    return allocMatrix(TYPEOF(sWhat), 0, 0);
  }

  /* count number of columns */
  if (use_ncol < 1) {
    if (TYPEOF(s) == RAWSXP) {
      ncol = 1;
      c = sraw;
      le = memchr(sraw, '\n', send - sraw);
      while ((c = memchr(c, (unsigned char) sep, le - c))) { ncol++; c++; }
    } else {
      c = CHAR(STRING_ELT(s, 0));
      while ((c = strchr(c, sep))) { ncol++; c++; }
      /* if sep and nsep are the same then the first "column" is the key and not the column */
      if (nsep == (int) (unsigned char) sep) ncol--;
    }
  } else ncol = use_ncol;

  /* allocate space for the result */
  N = ncol * nrow;
  switch(TYPEOF(sWhat)) {
    case LGLSXP:
    case INTSXP:
    case REALSXP:
    case CPLXSXP:
    case STRSXP:
    case RAWSXP:
      res = PROTECT(allocMatrix(TYPEOF(sWhat), nrow, ncol));
      break;

    default:
      Rf_error("Unsupported input to what.");
      break;
  }
  if (nsep >= 0) {
    SEXP dn;
    setAttrib(res, R_DimNamesSymbol, (dn = allocVector(VECSXP, 2)));
    SET_VECTOR_ELT(dn, 0, (rnam = allocVector(STRSXP, nrow)));
  }
  np++;

  /* cycle over the rows and parse the data */
  for (i = 0; i < nrow; i++) {
    int j = i;

    /* find the row of data */
    if (TYPEOF(s) == RAWSXP) {
        l = sraw;
        le = memchr(l, '\n', send - l);
        if (!le) le = send;
        sraw = le + 1;
    } else {
        l = CHAR(STRING_ELT(s, i + skip));
        le = l + strlen(l);
    }

    /* if nsep, load rowname */
    if (nsep >= 0) {
      c = memchr(l, nsep, le - l);
      if (c) {
        SET_STRING_ELT(rnam, i, Rf_mkCharLen(l, c - l));
        l = c + 1;
      } else
        SET_STRING_ELT(rnam, i, R_BlankString);
    }

    /* now split the row into elements */
    while (l < le) {
      if (!(c = memchr(l, sep, le - l)))
        c = le;

      if (j >= N) {
        if (resilient) break;
        Rf_error("line %lu: too many columns (expected %u)", (unsigned long)(i + 1), ncol);
      }

      switch(TYPEOF(sWhat)) {
      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(res)[j] = (tr || fa) ? tr : NA_INTEGER;
        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(res)[j] = Strtoi(num_buf, 10);
        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(res)[j] = R_atof(num_buf);
        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(res)[j] = strtoc(num_buf, TRUE);
        break;

      case STRSXP:
        SET_STRING_ELT(res, j, Rf_mkCharLen(l, c - l));
        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(res)[j] = strtoraw(num_buf);
        break;
      }
      l = c + 1;
      j += nrow;
    }

    /* fill up unused columns with NAs */
    while (j < N) {
      switch (TYPEOF(sWhat)) {
      case LGLSXP:
        LOGICAL(res)[j] = NA_INTEGER;
        break;

      case INTSXP:
        INTEGER(res)[j] = NA_INTEGER;
        break;

      case REALSXP:
        REAL(res)[j] = NA_REAL;
        break;

      case CPLXSXP:
        COMPLEX(res)[j].r = NA_REAL;
        COMPLEX(res)[j].i = NA_REAL;
        break;

      case STRSXP:
        SET_STRING_ELT(res, j, R_NaString);
        break;

      case RAWSXP:
        RAW(res)[j] = (Rbyte) 0;
        break;
      }
      j += nrow;
    }
  }

  UNPROTECT(np);
  return res;
}
Пример #26
0
SEXP attribute_hidden do_substrgets(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP s, x, sa, so, value, el, v_el;
    R_xlen_t i, len;
    int start, stop, k, l, v;
    size_t slen;
    cetype_t ienc, venc;
    const char *ss, *v_ss;
    char *buf;
    const void *vmax;

    checkArity(op, args);
    x = CAR(args);
    sa = CADR(args);
    so = CADDR(args);
    value = CADDDR(args);
    k = LENGTH(sa);
    l = LENGTH(so);

    if (!isString(x))
	error(_("replacing substrings in a non-character object"));
    len = LENGTH(x);
    PROTECT(s = allocVector(STRSXP, len));
    if (len > 0) {
	if (!isInteger(sa) || !isInteger(so) || k == 0 || l == 0)
	    error(_("invalid substring arguments"));

	v = LENGTH(value);
	if (!isString(value) || v == 0) error(_("invalid value"));
	
	vmax = vmaxget();
	for (i = 0; i < len; i++) {
	    el = STRING_ELT(x, i);
	    v_el = STRING_ELT(value, i % v);
	    start = INTEGER(sa)[i % k];
	    stop = INTEGER(so)[i % l];
	    if (el == NA_STRING || v_el == NA_STRING ||
		start == NA_INTEGER || stop == NA_INTEGER) {
		SET_STRING_ELT(s, i, NA_STRING);
		continue;
	    }
	    ienc = getCharCE(el);
	    ss = CHAR(el);
	    slen = strlen(ss);
	    if (start < 1) start = 1;
	    if (stop > slen) stop = (int) slen; /* SBCS optimization */
	    if (start > stop) {
		/* just copy element across */
		SET_STRING_ELT(s, i, STRING_ELT(x, i));
	    } else {
		int ienc2 = ienc;
		v_ss = CHAR(v_el);
		/* is the value in the same encoding?
		   FIXME: could prefer UTF-8 here
		 */
		venc = getCharCE(v_el);
		if (venc != ienc && !strIsASCII(v_ss)) {
		    ss = translateChar(el);
		    slen = strlen(ss);
		    v_ss = translateChar(v_el);
		    ienc2 = CE_NATIVE;
		}
		/* might expand under MBCS */
		buf = R_AllocStringBuffer(slen+strlen(v_ss), &cbuff);
		strcpy(buf, ss);
		substrset(buf, v_ss, ienc2, start, stop);
		SET_STRING_ELT(s, i, mkCharCE(buf, ienc2));
	    }
	    vmaxset(vmax);
	}
	R_FreeStringBufferL(&cbuff);
    }
    UNPROTECT(1);
    return s;
}
Пример #27
0
  SEXP spPPGLM(SEXP Y_r, SEXP X_r, SEXP p_r, SEXP n_r, SEXP family_r, SEXP weights_r,
	       SEXP m_r, SEXP knotsD_r, SEXP knotsCoordsD_r, 
	       SEXP betaPrior_r, SEXP betaNorm_r, SEXP sigmaSqIG_r, SEXP nuUnif_r, SEXP phiUnif_r,
	       SEXP phiStarting_r, SEXP sigmaSqStarting_r, SEXP nuStarting_r, SEXP betaStarting_r, SEXP w_strStarting_r,
	       SEXP phiTuning_r, SEXP sigmaSqTuning_r, SEXP nuTuning_r, SEXP betaTuning_r, SEXP w_strTuning_r,
	       SEXP covModel_r, SEXP nSamples_r, SEXP verbose_r, SEXP nReport_r){
    
    /*****************************************
                Common variables
    *****************************************/
    int i,j,k,l,info,nProtect= 0;
    char const *lower = "L";
    char const *upper = "U";
    char const *ntran = "N";
    char const *ytran = "T";
    char const *rside = "R";
    char const *lside = "L";
    const double one = 1.0;
    const double negOne = -1.0;
    const double zero = 0.0;
    const int incOne = 1;

    /*****************************************
                     Set-up
    *****************************************/
    double *Y = REAL(Y_r);
    double *X = REAL(X_r);
    int p = INTEGER(p_r)[0];
    int pp = p*p;
    int n = INTEGER(n_r)[0];

    std::string family = CHAR(STRING_ELT(family_r,0));

    int *weights = INTEGER(weights_r);

    //covariance model
    std::string covModel = CHAR(STRING_ELT(covModel_r,0));

    int m = INTEGER(m_r)[0];
    double *knotsD = REAL(knotsD_r);
    double *knotsCoordsD = REAL(knotsCoordsD_r);

    //priors and starting
    std::string betaPrior = CHAR(STRING_ELT(betaPrior_r,0));

    double *betaMu = NULL;
    double *betaSd = NULL;
    
    if(betaPrior == "normal"){
      betaMu = REAL(VECTOR_ELT(betaNorm_r, 0)); 
      betaSd = REAL(VECTOR_ELT(betaNorm_r, 1));
    }
    
    double *sigmaSqIG = REAL(sigmaSqIG_r);
    double *phiUnif = REAL(phiUnif_r);

    double phiStarting = REAL(phiStarting_r)[0];
    double sigmaSqStarting = REAL(sigmaSqStarting_r)[0];
    double *betaStarting = REAL(betaStarting_r);
    double *w_strStarting = REAL(w_strStarting_r);

    double sigmaSqIGa = sigmaSqIG[0]; double sigmaSqIGb = sigmaSqIG[1];
    double phiUnifa = phiUnif[0]; double phiUnifb = phiUnif[1];

    //if matern
    double *nuUnif = NULL;
    double nuStarting = 0;
    double nuUnifa = 0, nuUnifb = 0;
    if(covModel == "matern"){
      nuUnif = REAL(nuUnif_r);
      nuStarting = REAL(nuStarting_r)[0];
      nuUnifa = nuUnif[0]; nuUnifb = nuUnif[1]; 
    }

    //tuning
    double *betaTuning = (double *) R_alloc(p*p, sizeof(double)); 
    F77_NAME(dcopy)(&pp, REAL(betaTuning_r), &incOne, betaTuning, &incOne);
    double phiTuning = sqrt(REAL(phiTuning_r)[0]);
    double sigmaSqTuning = sqrt(REAL(sigmaSqTuning_r)[0]);
    double *w_strTuning = REAL(w_strTuning_r);
   
    double nuTuning = 0;
    if(covModel == "matern")
      nuTuning = sqrt(REAL(nuTuning_r)[0]);

    int nSamples = INTEGER(nSamples_r)[0];
    int verbose = INTEGER(verbose_r)[0];
    int nReport = INTEGER(nReport_r)[0];

    if(verbose){
      Rprintf("----------------------------------------\n");
      Rprintf("\tGeneral model description\n");
      Rprintf("----------------------------------------\n");
      Rprintf("Model fit with %i observations.\n\n", n);
      Rprintf("Number of covariates %i (including intercept if specified).\n\n", p);
      Rprintf("Using the %s spatial correlation model.\n\n", covModel.c_str());
      
      Rprintf("Using non-modified predictive process with %i knots.\n\n", m);
    
      Rprintf("Number of MCMC samples %i.\n\n", nSamples);

      Rprintf("Priors and hyperpriors:\n");

      if(betaPrior == "flat"){
	Rprintf("\tbeta flat.\n");
      }else{
	Rprintf("\tbeta normal:\n");
	Rprintf("\t\tmu:"); printVec(betaMu, p);
	Rprintf("\t\tsd:"); printVec(betaSd, p);Rprintf("\n");
      }
      Rprintf("\n");
  
      Rprintf("\tsigma.sq IG hyperpriors shape=%.5f and scale=%.5f\n", sigmaSqIGa, sigmaSqIGb);
      Rprintf("\n");
      
      Rprintf("\tphi Unif hyperpriors a=%.5f and b=%.5f\n", phiUnifa, phiUnifb);
      Rprintf("\n");
      
      if(covModel == "matern"){
	Rprintf("\tnu Unif hyperpriors a=%.5f and b=%.5f\n", nuUnifa, nuUnifb);	  
      }

      Rprintf("Metropolis tuning values:\n");
  
      Rprintf("\tbeta tuning:\n");
      printMtrx(betaTuning, p, p);
      Rprintf("\n"); 

      Rprintf("\tsigma.sq tuning: %.5f\n", sigmaSqTuning);
      Rprintf("\n");

      Rprintf("\tphi tuning: %.5f\n", phiTuning);
      Rprintf("\n");

      if(covModel == "matern"){
	Rprintf("\tnu tuning: %.5f\n", nuTuning);
	Rprintf("\n");
      }

      Rprintf("Metropolis starting values:\n");
  
      Rprintf("\tbeta starting:\n");
      Rprintf("\t"); printVec(betaStarting, p);
      Rprintf("\n"); 

      Rprintf("\tsigma.sq starting: %.5f\n", sigmaSqStarting);
      Rprintf("\n");

      Rprintf("\tphi starting: %.5f\n", phiStarting);
      Rprintf("\n");

      if(covModel == "matern"){
	Rprintf("\tnu starting: %.5f\n", nuStarting);
	Rprintf("\n");
      }

    } 

    /*****************************************
         Set-up MCMC sample matrices etc.
    *****************************************/
    int nn = n*n, nm = n*m, mm = m*m;

    //spatial parameters
    int nParams, betaIndx, sigmaSqIndx, phiIndx, nuIndx;

    if(covModel != "matern"){
      nParams = p+2;//sigma^2, phi
      betaIndx = 0; sigmaSqIndx = betaIndx+p; phiIndx = sigmaSqIndx+1;
    }else{
      nParams = p+3;//sigma^2, phi, nu
      betaIndx = 0; sigmaSqIndx = betaIndx+p; phiIndx = sigmaSqIndx+1; nuIndx = phiIndx+1;
    }

    double *spParams = (double *) R_alloc(nParams, sizeof(double));
    
    //set starting
    F77_NAME(dcopy)(&p, betaStarting, &incOne, &spParams[betaIndx], &incOne);

    spParams[sigmaSqIndx] = log(sigmaSqStarting);

    spParams[phiIndx] = logit(phiStarting, phiUnifa, phiUnifb);

    if(covModel == "matern") 
      spParams[nuIndx] = logit(nuStarting, nuUnifa, nuUnifb);

    double *wCurrent = (double *) R_alloc(n, sizeof(double));
    double *w_strCurrent = (double *) R_alloc(m, sizeof(double));
    F77_NAME(dcopy)(&m, w_strStarting, &incOne, w_strCurrent, &incOne);

    //samples and random effects
    SEXP w_r, w_str_r, samples_r, accept_r;

    PROTECT(w_r = allocMatrix(REALSXP, n, nSamples)); nProtect++; 
    double *w = REAL(w_r); zeros(w, n*nSamples);

    PROTECT(w_str_r = allocMatrix(REALSXP, m, nSamples)); nProtect++; 
    double *w_str = REAL(w_str_r); zeros(w_str, m*nSamples);

    PROTECT(samples_r = allocMatrix(REALSXP, nParams, nSamples)); nProtect++; 
    double *samples = REAL(samples_r);

    PROTECT(accept_r = allocMatrix(REALSXP, 1, 1)); nProtect++;


    /*****************************************
       Set-up MCMC alg. vars. matrices etc.
    *****************************************/
    int s=0, status=0, rtnStatus=0, accept=0, batchAccept = 0;
    double logPostCurrent = 0, logPostCand = 0, detCand = 0;
  
    double *P = (double *) R_alloc(nm, sizeof(double));
    double *K = (double *) R_alloc(mm, sizeof(double));
    double *tmp_n = (double *) R_alloc(n, sizeof(double));
    double *tmp_m = (double *) R_alloc(m, sizeof(double));
    double *tmp_nm = (double *) R_alloc(nm, sizeof(double));
    double *theta = (double *) R_alloc(3, sizeof(double)); //phi, nu, and perhaps more in the future

    double *candSpParams = (double *) R_alloc(nParams, sizeof(double));
    double *w_strCand = (double *) R_alloc(m, sizeof(double));
    double *wCand = (double *) R_alloc(n, sizeof(double));
    double sigmaSq, phi, nu;
    double *beta = (double *) R_alloc(p, sizeof(double));

    double logMHRatio;

    if(verbose){
      Rprintf("-------------------------------------------------\n");
      Rprintf("\t\tSampling\n");
      Rprintf("-------------------------------------------------\n");
      #ifdef Win32
        R_FlushConsole();
      #endif
    }

    logPostCurrent = R_NegInf;

    GetRNGstate();
    for(s = 0; s < nSamples; s++){
 
      //propose   
      mvrnorm(&candSpParams[betaIndx], &spParams[betaIndx], betaTuning, p, false);
      F77_NAME(dcopy)(&p, &candSpParams[betaIndx], &incOne, beta, &incOne);

      candSpParams[sigmaSqIndx] = rnorm(spParams[sigmaSqIndx], sigmaSqTuning);
      sigmaSq = theta[0] = exp(candSpParams[sigmaSqIndx]);

      candSpParams[phiIndx] = rnorm(spParams[phiIndx], phiTuning);
      phi = theta[1] = logitInv(candSpParams[phiIndx], phiUnifa, phiUnifb);

      if(covModel == "matern"){
	candSpParams[nuIndx] = rnorm(spParams[nuIndx], nuTuning);
	nu = theta[2] = logitInv(candSpParams[nuIndx], nuUnifa, nuUnifb);
      }

      for(i = 0; i < m; i++){
	w_strCand[i] = rnorm(w_strCurrent[i], sqrt(w_strTuning[i]));
      }
      
      //construct covariance matrices 
      spCovLT(knotsD, m, theta, covModel, K);
      spCov(knotsCoordsD, nm, theta, covModel, P);
    
      //invert C and log det cov
      detCand = 0;
      F77_NAME(dpotrf)(lower, &m, K, &m, &info); if(info != 0){error("c++ error: Cholesky failed in spGLM\n");}
      for(i = 0; i < m; i++) detCand += 2*log(K[i*m+i]);
      F77_NAME(dpotri)(lower, &m, K, &m, &info); if(info != 0){error("c++ error: Cholesky inverse failed in spGLM\n");}
      
      //make \tild{w}
      F77_NAME(dsymv)(lower, &m, &one, K, &m, w_strCand, &incOne, &zero, tmp_m, &incOne);     
      F77_NAME(dgemv)(ytran, &m, &n, &one, P, &m, tmp_m, &incOne, &zero, wCand, &incOne);
      
      //Likelihood with Jacobian  
      logPostCand = 0.0;

      if(betaPrior == "normal"){
	for(i = 0; i < p; i++){
	  logPostCand += dnorm(beta[i], betaMu[i], betaSd[i], 1);
	}
      }

      logPostCand += -1.0*(1.0+sigmaSqIGa)*log(sigmaSq)-sigmaSqIGb/sigmaSq+log(sigmaSq); 
       
      logPostCand += log(phi - phiUnifa) + log(phiUnifb - phi); 

      if(covModel == "matern"){
	logPostCand += log(nu - nuUnifa) + log(nuUnifb - nu);   
      }

      F77_NAME(dgemv)(ntran, &n, &p, &one, X, &n, beta, &incOne, &zero, tmp_n, &incOne);
      
      if(family == "binomial"){
	logPostCand += binomial_logpost(n, Y, tmp_n, wCand, weights);
      }else if(family == "poisson"){
	logPostCand += poisson_logpost(n, Y, tmp_n, wCand, weights);
      }else{
	error("c++ error: family misspecification in spGLM\n");
      }

      //(-1/2) * tmp_n` *  C^-1 * tmp_n
      logPostCand += -0.5*detCand-0.5*F77_NAME(ddot)(&m, w_strCand, &incOne, tmp_m, &incOne);

      //
      //MH accept/reject	
      //      
  
      //MH ratio with adjustment
      logMHRatio = logPostCand - logPostCurrent;
      
      if(runif(0.0,1.0) <= exp(logMHRatio)){
	F77_NAME(dcopy)(&nParams, candSpParams, &incOne, spParams, &incOne);
	F77_NAME(dcopy)(&n, wCand, &incOne, wCurrent, &incOne);
	F77_NAME(dcopy)(&m, w_strCand, &incOne, w_strCurrent, &incOne);
	logPostCurrent = logPostCand;
	accept++;
	batchAccept++;
      }
      
      /******************************
          Save samples and report
      *******************************/
      F77_NAME(dcopy)(&nParams, spParams, &incOne, &samples[s*nParams], &incOne);
      F77_NAME(dcopy)(&n, wCurrent, &incOne, &w[s*n], &incOne);
      F77_NAME(dcopy)(&m, w_strCurrent, &incOne, &w_str[s*m], &incOne);
      
      //report
      if(verbose){
	if(status == nReport){
	  Rprintf("Sampled: %i of %i, %3.2f%%\n", s, nSamples, 100.0*s/nSamples);
	  Rprintf("Report interval Metrop. Acceptance rate: %3.2f%%\n", 100.0*batchAccept/nReport);
	  Rprintf("Overall Metrop. Acceptance rate: %3.2f%%\n", 100.0*accept/s);
	  Rprintf("-------------------------------------------------\n");
          #ifdef Win32
	  R_FlushConsole();
          #endif
	  status = 0;
	  batchAccept = 0;
	}
      }
      status++;
   
      R_CheckUserInterrupt();
    }//end sample loop
    PutRNGstate();
    
    //final status report
    if(verbose){
      Rprintf("Sampled: %i of %i, %3.2f%%\n", s, nSamples, 100.0*s/nSamples);
      Rprintf("-------------------------------------------------\n");
      #ifdef Win32
      R_FlushConsole();
      #endif
    }

    //untransform variance variables
    for(s = 0; s < nSamples; s++){
      samples[s*nParams+sigmaSqIndx] = exp(samples[s*nParams+sigmaSqIndx]);

      samples[s*nParams+phiIndx] = logitInv(samples[s*nParams+phiIndx], phiUnifa, phiUnifb);

      if(covModel == "matern")
	samples[s*nParams+nuIndx] = logitInv(samples[s*nParams+nuIndx], nuUnifa, nuUnifb);
    }
   
    //calculate acceptance rate
    REAL(accept_r)[0] = 100.0*accept/s;

    //make return object
    SEXP result, resultNames;
    
    int nResultListObjs = 4;

    PROTECT(result = allocVector(VECSXP, nResultListObjs)); nProtect++;
    PROTECT(resultNames = allocVector(VECSXP, nResultListObjs)); nProtect++;

   //samples
    SET_VECTOR_ELT(result, 0, samples_r);
    SET_VECTOR_ELT(resultNames, 0, mkChar("p.beta.theta.samples")); 

    SET_VECTOR_ELT(result, 1, accept_r);
    SET_VECTOR_ELT(resultNames, 1, mkChar("acceptance"));
    
    SET_VECTOR_ELT(result, 2, w_r);
    SET_VECTOR_ELT(resultNames, 2, mkChar("p.w.samples"));

    SET_VECTOR_ELT(result, 3, w_str_r);
    SET_VECTOR_ELT(resultNames, 3, mkChar("p.w.knots.samples"));
  
    namesgets(result, resultNames);
   
    //unprotect
    UNPROTECT(nProtect);
    
    return(result);
    
  }
Пример #28
0
SEXP attribute_hidden do_makenames(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP arg, ans;
    R_xlen_t i, n;
    int l, allow_;
    char *p, *tmp = NULL, *cbuf;
    const char *This;
    Rboolean need_prefix;
    const void *vmax;

    checkArity(op ,args);
    arg = CAR(args);
    if (!isString(arg))
	error(_("non-character names"));
    n = XLENGTH(arg);
    allow_ = asLogical(CADR(args));
    if (allow_ == NA_LOGICAL)
	error(_("invalid '%s' value"), "allow_");
    PROTECT(ans = allocVector(STRSXP, n));
    vmax = vmaxget();
    for (i = 0 ; i < n ; i++) {
	This = translateChar(STRING_ELT(arg, i));
	l = (int) strlen(This);
	/* need to prefix names not beginning with alpha or ., as
	   well as . followed by a number */
	need_prefix = FALSE;
	if (mbcslocale && This[0]) {
	    int nc = l, used;
	    wchar_t wc;
	    mbstate_t mb_st;
	    const char *pp = This;
	    mbs_init(&mb_st);
	    used = (int) Mbrtowc(&wc, pp, MB_CUR_MAX, &mb_st);
	    pp += used; nc -= used;
	    if (wc == L'.') {
		if (nc > 0) {
		    Mbrtowc(&wc, pp, MB_CUR_MAX, &mb_st);
		    if (iswdigit(wc))  need_prefix = TRUE;
		}
	    } else if (!iswalpha(wc)) need_prefix = TRUE;
	} else {
	    if (This[0] == '.') {
		if (l >= 1 && isdigit(0xff & (int) This[1])) need_prefix = TRUE;
	    } else if (!isalpha(0xff & (int) This[0])) need_prefix = TRUE;
	}
	if (need_prefix) {
	    tmp = Calloc(l+2, char);
	    strcpy(tmp, "X");
	    strcat(tmp, translateChar(STRING_ELT(arg, i)));
	} else {
	    tmp = Calloc(l+1, char);
	    strcpy(tmp, translateChar(STRING_ELT(arg, i)));
	}
	if (mbcslocale) {
	    /* This cannot lengthen the string, so safe to overwrite it.
	       Would also be possible a char at a time.
	     */
	    int nc = (int) mbstowcs(NULL, tmp, 0);
	    wchar_t *wstr = Calloc(nc+1, wchar_t), *wc;
	    if (nc >= 0) {
		mbstowcs(wstr, tmp, nc+1);
		for (wc = wstr; *wc; wc++) {
		    if (*wc == L'.' || (allow_ && *wc == L'_'))
			/* leave alone */;
		    else if (!iswalnum((int)*wc)) *wc = L'.';
		    /* If it changes into dot here,
		     * length will become short on mbcs.
		     * The name which became short will contain garbage.
		     * cf.
		     *   >  make.names(c("\u30fb"))
		     *   [1] "X.\0"
		     */
		}
		wcstombs(tmp, wstr, strlen(tmp)+1);
		Free(wstr);
	    } else error(_("invalid multibyte string %d"), i+1);
	} else {
	    for (p = tmp; *p; p++) {
Пример #29
0
SEXP do_subset_xts(SEXP x, SEXP sr, SEXP sc, SEXP drop) //SEXP s, SEXP call, int drop)
{
    SEXP attr, result, dim;
    int nr, nc, nrs, ncs;
    int i, j, ii, jj, ij, iijj;
    int mode;
    int *int_x=NULL, *int_result=NULL, *int_newindex=NULL, *int_index=NULL;
    double *real_x=NULL, *real_result=NULL, *real_newindex=NULL, *real_index=NULL;

    nr = nrows(x);
    nc = ncols(x);

    if( length(x)==0 )
      return x;

    dim = getAttrib(x, R_DimSymbol);

    nrs = LENGTH(sr);
    ncs = LENGTH(sc);
    int *int_sr=NULL, *int_sc=NULL;
    int_sr = INTEGER(sr);
    int_sc = INTEGER(sc);

    mode = TYPEOF(x);

    result = allocVector(mode, nrs*ncs);
    PROTECT(result);


    if( mode==INTSXP ) {
      int_x = INTEGER(x);
      int_result = INTEGER(result);
    } else
    if( mode==REALSXP ) {
      real_x = REAL(x);
      real_result = REAL(result);
    }

    /* code to handle index of xts object efficiently */
    SEXP index, newindex;
    int indx;

    index = getAttrib(x, install("index"));
    PROTECT(index);

    if(TYPEOF(index) == INTSXP) {
      newindex = allocVector(INTSXP, LENGTH(sr));
      PROTECT(newindex);
      int_newindex = INTEGER(newindex);
      int_index = INTEGER(index);
      for(indx = 0; indx < nrs; indx++) {
        int_newindex[indx] = int_index[ (int_sr[indx])-1];
      }
      copyAttributes(index, newindex);
      setAttrib(result, install("index"), newindex);
      UNPROTECT(1);
    }
    if(TYPEOF(index) == REALSXP) {
      newindex = allocVector(REALSXP, LENGTH(sr));
      PROTECT(newindex);
      real_newindex = REAL(newindex);
      real_index = REAL(index);
      for(indx = 0; indx < nrs; indx++) {
        real_newindex[indx] = real_index[ (int_sr[indx])-1 ];
      }
      copyAttributes(index, newindex);
      setAttrib(result, install("index"), newindex);
      UNPROTECT(1);
    }

    for (i = 0; i < nrs; i++) {
      ii = int_sr[i];
      if (ii != NA_INTEGER) {
        if (ii < 1 || ii > nr)
          error("i is out of range\n");
        ii--;
      }
      /* Begin column loop */
      for (j = 0; j < ncs; j++) {
        //jj = INTEGER(sc)[j];
        jj = int_sc[j];
        if (jj != NA_INTEGER) {
        if (jj < 1 || jj > nc)
          error("j is out of range\n");
        jj--;
        }
        ij = i + j * nrs;
        if (ii == NA_INTEGER || jj == NA_INTEGER) {
          switch ( mode ) {
            case REALSXP:
                 real_result[ij] = NA_REAL;
                 break;
            case LGLSXP:
            case INTSXP:
                 int_result[ij] = NA_INTEGER;
                 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:
                 error("xts subscripting not handled for this type");
                 break;
          }
        }
        else {
          iijj = ii + jj * nr;
          switch ( mode ) {
            case REALSXP:
                 real_result[ij] = real_x[iijj];
                 break;
            case LGLSXP:
                 LOGICAL(result)[ij] = LOGICAL(x)[iijj];
                 break;
            case INTSXP:
                 int_result[ij] = int_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(x, iijj));
                 break;
            case RAWSXP:
                 RAW(result)[ij] = RAW(x)[iijj];
                 break;
            default:
                 error("matrix subscripting not handled for this type");
                 break;
          }
        }
      } /* end of column loop */
    } /* end of row loop */
    if(nrs >= 0 && ncs >= 0 && !isNull(dim)) {
      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 && !isNull(dim)) {
    SEXP dimnames, dimnamesnames, newdimnames;
    dimnames = getAttrib(x, R_DimNamesSymbol);
    dimnamesnames = getAttrib(dimnames, R_NamesSymbol);
    if (!isNull(dimnames)) {
        PROTECT(newdimnames = allocVector(VECSXP, 2));
        if (TYPEOF(dimnames) == VECSXP) {
          SET_VECTOR_ELT(newdimnames, 0,
            xtsExtractSubset(VECTOR_ELT(dimnames, 0),
                  allocVector(STRSXP, nrs), sr));
          SET_VECTOR_ELT(newdimnames, 1,
            xtsExtractSubset(VECTOR_ELT(dimnames, 1),
                  allocVector(STRSXP, ncs), sc));
        }
        else {
          SET_VECTOR_ELT(newdimnames, 0,
            xtsExtractSubset(CAR(dimnames),
                  allocVector(STRSXP, nrs), sr));
          SET_VECTOR_ELT(newdimnames, 1,
            xtsExtractSubset(CADR(dimnames),
                  allocVector(STRSXP, ncs), sc));
        }
        setAttrib(newdimnames, R_NamesSymbol, dimnamesnames);
        setAttrib(result, R_DimNamesSymbol, newdimnames);
        UNPROTECT(1);
    }
    }

    copyAttributes(x, result);
    if(ncs == 1 && LOGICAL(drop)[0])
      setAttrib(result, R_DimSymbol, R_NilValue);

    UNPROTECT(2);
    return result;
}
Пример #30
0
SEXP Win_selectlist(SEXP args)
{
    SEXP choices, preselect, ans = R_NilValue;
    const char **clist;
    int i, j = -1, n, mw = 0, multiple, nsel = 0;
    int xmax, ymax, ylist, fht, h0;
    Rboolean haveTitle;

    choices = CAR(args);
    if(!isString(choices)) error(_("invalid '%s' argument"), "choices");
    preselect = CADR(args);
    if(!isNull(preselect) && !isString(preselect))
	error(_("invalid '%s' argument"), "preselect");
    multiple = asLogical(CADDR(args));
    if(multiple == NA_LOGICAL) multiple = 0;
    haveTitle = isString(CADDDR(args));
    if(!multiple && isString(preselect) && LENGTH(preselect) != 1)
	error(_("invalid '%s' argument"), "preselect");

    n = LENGTH(choices);
    clist = (const char **) R_alloc(n + 1, sizeof(char *));
    for(i = 0; i < n; i++) {
	clist[i] = translateChar(STRING_ELT(choices, i));
	mw = max(mw, gstrwidth(NULL, SystemFont, clist[i]));
    }
    clist[n] = NULL;

    fht = getSysFontSize().height;

    xmax = max(170, mw+60); /* allow for scrollbar */
    if(ismdi()) {
	RECT *pR = RgetMDIsize();
	h0 = pR->bottom;
    } else {
	h0 = deviceheight(NULL);
    }
    ymax = min(80+fht*n, h0-100); /* allow for window widgets, toolbar */
    ylist = ymax - 60;
    wselect = newwindow(haveTitle ? translateChar(STRING_ELT(CADDDR(args), 0)):
			(multiple ? _("Select one or more") : _("Select one")),
			rect(0, 0, xmax, ymax),
			Titlebar | Centered | Modal | Floating);
    setbackground(wselect, dialog_bg());
    if(multiple)
	f_list = newmultilist(clist, rect(10, 10, xmax-25, ylist), NULL, finish);
    else
	f_list = newlistbox(clist, rect(10, 10, xmax-25, ylist), NULL, finish);
    if(!isNull(preselect) && LENGTH(preselect)) {
	for(i = 0; i < n; i++)
	    for(j = 0; j < LENGTH(preselect); j++)
		if(strcmp(clist[i], translateChar(STRING_ELT(preselect, j))) == 0) {
		    setlistitem(f_list, i);
		    break;
		}
    }
    bFinish = newbutton(G_("OK"), rect(xmax-160, ymax-40, 70, 25), finish);
    bCancel = newbutton(G_("Cancel"), rect(xmax-80, ymax-40, 70, 25), cancel);
    setkeydown(wselect, key1);
    show(wselect);
    done = 0;
    while(!done) {
	R_WaitEvent();
	R_ProcessEvents();
    }

    if(multiple) {
	if (done == 1) { /* Finish */
	    for(i = 0; i < n; i++)  if(isselected(f_list, i)) nsel++;
	    PROTECT(ans = allocVector(STRSXP, nsel));
	    for(i = 0, j = 0; i < n; i++)
		if(isselected(f_list, i))
		    SET_STRING_ELT(ans, j++, mkChar(clist[i]));
	} else { /* cancel */
	    PROTECT(ans = allocVector(STRSXP, 0));
	}
    } else
	PROTECT(ans = mkString(selected));

    cleanup();
    show(RConsole);
    R_ProcessEvents();
    UNPROTECT(1);
    return ans;
}