Пример #1
0
SEXP _dots_unpack(SEXP dots) {
  int i;
  SEXP s;
  int length = 0;
  SEXP names, environments, expressions, values;
  //SEXP evaluated, codeptr, missing, wraplist;
  //SEXP seen;

  SEXP dataFrame;
  SEXP colNames;

  //check inputs and measure length
  length = _dots_length(dots);

  // unpack information for each item:
  // names, environemnts, expressions, values, evaluated, seen
  PROTECT(names = allocVector(STRSXP, length));
  PROTECT(environments = allocVector(VECSXP, length));
  PROTECT(expressions = allocVector(VECSXP, length));
  PROTECT(values = allocVector(VECSXP, length));

  for (s = dots, i = 0; i < length; s = CDR(s), i++) {
    if (TYPEOF(s) != DOTSXP && TYPEOF(s) != LISTSXP)
      error("Expected dotlist or pairlist, got %s at index %d", type2char(TYPEOF(s)), i);

    SEXP item = CAR(s);
    if (item == R_MissingArg) item = emptypromise();

    if (TYPEOF(item) != PROMSXP)
      error("Expected PROMSXP as CAR of DOTSXP, got %s", type2char(TYPEOF(item)));

    // if we have an unevluated promise whose code is another promise, descend
    while ((PRENV(item) != R_NilValue) && (TYPEOF(PRCODE(item)) == PROMSXP)) {
      item = PRCODE(item);
    }

    if ((TYPEOF(PRENV(item)) != ENVSXP) && (PRENV(item) != R_NilValue))
      error("Expected ENVSXP or NULL in environment slot of DOTSXP, got %s",
            type2char(TYPEOF(item)));

    SET_STRING_ELT(names, i, isNull(TAG(s)) ? mkChar("") : PRINTNAME(TAG(s)));
    SET_VECTOR_ELT(environments, i, PRENV(item));
    SET_VECTOR_ELT(expressions, i, PREXPR(item));

    if (PRVALUE(item) != R_UnboundValue) {
      SET_VECTOR_ELT(values, i, PRVALUE(item));
    } else {
      SET_VECTOR_ELT(values, i, R_NilValue);
    }
  }
  PROTECT(dataFrame = allocVector(VECSXP, 4));
  SET_VECTOR_ELT(dataFrame, 0, names);
  SET_VECTOR_ELT(dataFrame, 1, environments);
  SET_VECTOR_ELT(dataFrame, 2, expressions);
  SET_VECTOR_ELT(dataFrame, 3, values);

  PROTECT(colNames = allocVector(STRSXP, 4));
  SET_STRING_ELT(colNames, 0, mkChar("name"));
  SET_STRING_ELT(colNames, 1, mkChar("envir"));
  SET_STRING_ELT(colNames, 2, mkChar("expr"));
  SET_STRING_ELT(colNames, 3, mkChar("value"));

  setAttrib(expressions, R_ClassSymbol, ScalarString(mkChar("deparse")));
  setAttrib(environments, R_ClassSymbol, ScalarString(mkChar("deparse")));
  setAttrib(values, R_ClassSymbol, ScalarString(mkChar("deparse")));

  setAttrib(dataFrame, R_NamesSymbol, colNames);
  setAttrib(dataFrame, R_RowNamesSymbol, names);
  setAttrib(dataFrame, R_ClassSymbol, ScalarString(mkChar("data.frame")));

  UNPROTECT(6);
  return(dataFrame);
}
Пример #2
0
SEXP attribute_hidden do_sprintf(/*const*/ CXXR::Expression* call, const CXXR::BuiltInFunction* op, CXXR::Environment* env, CXXR::RObject* const* args, int num_args, const CXXR::PairList* tags)
{
    int i, nargs, cnt, v, thislen, nfmt, nprotect = 0;
    /* fmt2 is a copy of fmt with '*' expanded.
       bit will hold numeric formats and %<w>s, so be quite small. */
    char fmt[MAXLINE+1], fmt2[MAXLINE+10], *fmtp, bit[MAXLINE+1],
	*outputString;
    const char *formatString;
    size_t n, cur, chunk;

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

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

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

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

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

    CHECK_maxlen;

    outputString = CXXRCONSTRUCT(static_cast<char*>, R_AllocStringBuffer(0, &outbuff));

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

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

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

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

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

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

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

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

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

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

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

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

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

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

			if(!did_this)
			    CHECK_this_length;

			switch(TYPEOF(_this)) {
			case LGLSXP:
			    {
				int x = LOGICAL(_this)[ns % thislen];
				if (checkfmt(fmtp, "di"))
				    error(_("invalid format '%s'; %s"), fmtp,
					  _("use format %d or %i for logical objects"));
				if (x == NA_LOGICAL) {
				    fmtp[strlen(fmtp)-1] = 's';
				    _my_sprintf("NA")
				} else {
				    _my_sprintf(x)
				}
				break;
			    }
			case INTSXP:
			    {
				int x = INTEGER(_this)[ns % thislen];
				if (checkfmt(fmtp, "dioxX"))
				    error(_("invalid format '%s'; %s"), fmtp,
					  _("use format %d, %i, %o, %x or %X for integer objects"));
				if (x == NA_INTEGER) {
				    fmtp[strlen(fmtp)-1] = 's';
				    _my_sprintf("NA")
				} else {
				    _my_sprintf(x)
				}
				break;
			    }
Пример #3
0
/* conditional linear Gaussian mutual information test. */
static double ct_micg(SEXP xx, SEXP yy, SEXP zz, int nobs, int ntests,
    double *pvalue, double *df) {

int xtype = 0, ytype = TYPEOF(yy), *nlvls = NULL, llx = 0, lly = 0, llz = 0;
int ndp = 0, ngp = 0, nsx = length(zz), **dp = NULL, *dlvls = NULL, j = 0, k = 0;
int i = 0, *zptr = 0;
void *xptr = NULL, *yptr = NULL, **columns = NULL;
double **gp = NULL;
double statistic = 0;
SEXP xdata;

  if (ytype == INTSXP) {

    /* cache the number of levels. */
    lly = NLEVELS(yy);
    yptr = INTEGER(yy);

  }/*THEN*/
  else {

    yptr = REAL(yy);

  }/*ELSE*/

  /* extract the conditioning variables and cache their types. */
  columns = Calloc1D(nsx, sizeof(void *));
  nlvls = Calloc1D(nsx, sizeof(int));
  df2micg(zz, columns, nlvls, &ndp, &ngp);

  dp = Calloc1D(ndp + 1, sizeof(int *));
  gp = Calloc1D(ngp + 1, sizeof(double *));
  dlvls = Calloc1D(ndp + 1, sizeof(int));
  for (i = 0, j = 0, k = 0; i < nsx; i++)
    if (nlvls[i] > 0) {

      dlvls[1 + j] = nlvls[i];
      dp[1 + j++] = columns[i];

    }/*THEN*/
    else {

      gp[1 + k++] = columns[i];

    }/*ELSE*/

  /* allocate vector for the configurations of the discrete parents; or, if
   * there no discrete parents, for the means of the continuous parents. */
  if (ndp > 0) {

    zptr = Calloc1D(nobs, sizeof(int));
    c_fast_config(dp + 1, nobs, ndp, dlvls + 1, zptr, &llz, 1);

  }/*THEN*/

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

    xdata = VECTOR_ELT(xx, i);
    xtype = TYPEOF(xdata);

    if (xtype == INTSXP) {

      xptr = INTEGER(xdata);
      llx = NLEVELS(xdata);

    }/*THEN*/
    else {

      xptr = REAL(xdata);

    }/*ELSE*/

    if ((ytype == INTSXP) && (xtype == INTSXP)) {

      if (ngp > 0) {

        /* need to reverse conditioning to actually compute the test. */
        statistic = 2 * nobs * nobs *
                      c_cmicg_unroll(xptr, llx, yptr, lly, zptr, llz,
                                 gp + 1, ngp, df, nobs);

      }/*THEN*/
      else {

        /* the test reverts back to a discrete mutual information test. */
        statistic = 2 * nobs * c_cchisqtest(xptr, llx, yptr, lly, zptr, llz,
                                 nobs, df, MI);

      }/*ELSE*/

    }/*THEN*/
    else if ((ytype == REALSXP) && (xtype == REALSXP)) {

      gp[0] = xptr;
      statistic = 2 * nobs * c_cmicg(yptr, gp, ngp + 1, NULL, 0, zptr, llz,
                               dlvls, nobs);
      /* one regression coefficient for each conditioning level is added;
       * if all conditioning variables are continuous that's just one global
       * regression coefficient. */
      *df = (llz == 0) ? 1 : llz;

    }/*THEN*/
    else if ((ytype == INTSXP) && (xtype == REALSXP)) {

      dp[0] = yptr;
      dlvls[0] = lly;
      statistic = 2 * nobs * c_cmicg(xptr, gp + 1, ngp, dp, ndp + 1, zptr,
                               llz, dlvls, nobs);

      /* for each additional configuration of the discrete conditioning
       * variables plus the discrete yptr, one whole set of regression
       * coefficients (plus the intercept) is added. */
      *df = (lly - 1) * ((llz == 0) ? 1 : llz)  * (ngp + 1);

    }/*THEN*/
    else if ((ytype == REALSXP) && (xtype == INTSXP)) {

      dp[0] = xptr;
      dlvls[0] = llx;
      statistic = 2 * nobs * c_cmicg(yptr, gp + 1, ngp, dp, ndp + 1, zptr,
                               llz, dlvls, nobs);
      /* same as above, with xptr and yptr swapped. */
      *df = (llx - 1) * ((llz == 0) ? 1 : llz) * (ngp + 1);

    }/*ELSE*/

    pvalue[i] = pchisq(statistic, *df, FALSE, FALSE);

  }/*FOR*/

  Free1D(columns);
  Free1D(nlvls);
  Free1D(dlvls);
  Free1D(zptr);
  Free1D(dp);
  Free1D(gp);

  return statistic;

}/*CT_MICG*/
Пример #4
0
  SEXP imputeObservations(SEXP R_forest, SEXP registered_data, SEXP new_data)
  {
    hpdRFforest *forest = (hpdRFforest *) R_ExternalPtrAddr(R_forest);
    int temp_leaf_count, leaf_count=0, num_obs = length(VECTOR_ELT(new_data,0));
    hpdRFnode **temp_leaves, **leaves = NULL;
    void **new_feature_observations = 
      (void **) malloc(sizeof(void*)*length(new_data));
    bool* new_int_data = (bool *) malloc(sizeof(bool)*length(new_data));
    void **old_feature_observations = 
      (void **) malloc(sizeof(void*)*length(registered_data));
    bool* old_int_data = (bool *) malloc(sizeof(bool)*length(registered_data));
    double *temp_weights, *weights;
    for(int col = 0; col < length(new_data); col++)
      {
	new_feature_observations[col] = 
	  RtoCArray<void *>(VECTOR_ELT(new_data,col));
	new_int_data[col] = TYPEOF(VECTOR_ELT(new_data,col)) == INTSXP;
      }
    for(int col = 0; col < length(registered_data); col++)
      {
	old_feature_observations[col] = 
	  RtoCArray<void *>(VECTOR_ELT(registered_data,col));
	old_int_data[col] = TYPEOF(VECTOR_ELT(registered_data,col)) == INTSXP;
      }


    for(int obs_index = 0; obs_index < num_obs; obs_index++)
      {
	for(int i = 0; i < forest->ntree; i++)
	  {
	    temp_leaf_count = 0;
	    temp_leaves=
	      treeTraverseObservation(forest->trees[i], 
				      new_data,
				      forest->features_cardinality, 
				      obs_index,
				      true, 
				      &temp_leaf_count, &temp_weights);
	    hpdRFnode** temp = (hpdRFnode**) 
	      malloc(sizeof(hpdRFnode*)*(temp_leaf_count+leaf_count));
	    double* temp1 = (double *) 
	      malloc(sizeof(double)*(temp_leaf_count+leaf_count));

	    double total_tree_weight = 0;
	    for(int j = 0; j < temp_leaf_count; j++)
	      total_tree_weight += temp_leaves[j]->additional_info->num_obs;
	    for(int j = 0; j < temp_leaf_count; j++)
	      temp_weights[j] = temp_leaves[j]->additional_info->num_obs/
		total_tree_weight;

	    if(leaf_count != 0)
	      {
		memcpy(temp,leaves,leaf_count*sizeof(hpdRFnode*));
		memcpy(temp1,weights, leaf_count*sizeof(double));
	      }
	    if(temp_leaf_count != 0)
	      {
		memcpy(temp+leaf_count,temp_leaves,
		       temp_leaf_count*sizeof(hpdRFnode*));
		memcpy(temp1+leaf_count,temp_weights,
		       temp_leaf_count*sizeof(double));

	      }
	    free(temp_leaves);
	    free(leaves);
	    free(weights);
	    free(temp_weights);
	    leaves = temp;
	    weights = temp1;
	    leaf_count += temp_leaf_count;

	  }
	
	for(int i = 0; i < leaf_count; i++)
	  if(isnan(weights[i]))
	    weights[i] = 0;
	

	double sample_id = forest->ntree*((double)rand()/(double)RAND_MAX);
	int i = 0;

	while(i < leaf_count)
	  {
	    if(sample_id >= weights[i])
	      sample_id -= weights[i];
	    else
	      break;
	    i++;
	  }
	if(i < leaf_count && leaves[i]->additional_info->num_obs > 0)
	  {
	    int index = (int) (sample_id*leaves[i]->additional_info->num_obs);
	    index = leaves[i]->additional_info->indices[index]-1;
	    for(int col = 0; col < length(new_data); col++)
	      {
		if(new_int_data[col] && old_int_data[col])
		  {
		    ((int **) new_feature_observations)[col][obs_index] = 
		      ((int **) old_feature_observations)[col][index];
		  }
		if(new_int_data[col] && !old_int_data[col])
		  {
		    ((int **) new_feature_observations)[col][obs_index] = 
		      ((double **) old_feature_observations)[col][index];
		  }
		if(!new_int_data[col] && old_int_data[col])
		  {
		    ((double **) new_feature_observations)[col][obs_index] = 
		      ((int **) old_feature_observations)[col][index];
		  }
		if(!new_int_data[col] && !old_int_data[col])
		  {
		    ((double **) new_feature_observations)[col][obs_index] = 
		      ((double **) old_feature_observations)[col][index];
		  }
	      }
	  }
	free(leaves);
	leaves = NULL;
	leaf_count = 0;
	free(weights);
	weights = NULL;
      }
    return R_NilValue;
  }
Пример #5
0
static SEXP ExtractSubset(SEXP x, SEXP result, SEXP indx) //, SEXP call)
{
    /* ExtractSubset is currently copied/inspired by subset.c from GNU-R
       This is slated to be reimplemented using the previous method
       in xts to get the correct dimnames
    */
    int i, ii, n, nx, mode;
    SEXP tmp, tmp2;
    mode = TYPEOF(x);
    n = LENGTH(indx); 
    nx = length(x);
    tmp = result;
    
    /*if (x == R_NilValue)*/
    if (isNull(x))
    return x;
    
    for (i = 0; i < n; i++) {
    ii = INTEGER(indx)[i];
    if (ii != NA_INTEGER)
        ii--;
    switch (mode) {
    case LGLSXP:
        if (0 <= ii && ii < nx && ii != NA_LOGICAL)
        LOGICAL(result)[i] = LOGICAL(x)[ii];
        else
        LOGICAL(result)[i] = NA_LOGICAL;
        break;
    case INTSXP:
        if (0 <= ii && ii < nx && ii != NA_INTEGER)
        INTEGER(result)[i] = INTEGER(x)[ii];
        else
        INTEGER(result)[i] = NA_INTEGER;
        break;
    case REALSXP:
        if (0 <= ii && ii < nx && ii != NA_INTEGER)
        REAL(result)[i] = REAL(x)[ii];
        else
        REAL(result)[i] = NA_REAL;
        break;
    case CPLXSXP:
        if (0 <= ii && ii < nx && ii != NA_INTEGER) {
        COMPLEX(result)[i] = COMPLEX(x)[ii];
        }
        else {
        COMPLEX(result)[i].r = NA_REAL;
        COMPLEX(result)[i].i = NA_REAL;
        }
        break;
    case STRSXP:
        if (0 <= ii && ii < nx && ii != NA_INTEGER)
        SET_STRING_ELT(result, i, STRING_ELT(x, ii));
        else
        SET_STRING_ELT(result, i, NA_STRING);
        break;
    case VECSXP:
    case EXPRSXP:
        if (0 <= ii && ii < nx && ii != NA_INTEGER)
        SET_VECTOR_ELT(result, i, VECTOR_ELT(x, ii));
        else
        SET_VECTOR_ELT(result, i, R_NilValue);
        break;
    case LISTSXP:
        /* cannot happen: pairlists are coerced to lists */
    case LANGSXP:
        if (0 <= ii && ii < nx && ii != NA_INTEGER) {
        tmp2 = nthcdr(x, ii);
        SETCAR(tmp, CAR(tmp2));
        SET_TAG(tmp, TAG(tmp2));
        }
        else
        SETCAR(tmp, R_NilValue);
        tmp = CDR(tmp);
        break;
    case RAWSXP:
        if (0 <= ii && ii < nx && ii != NA_INTEGER)
        RAW(result)[i] = RAW(x)[ii];
        else
        RAW(result)[i] = (Rbyte) 0;
        break;
    default:
        error("error in subset\n");
        break;
    }
    }
    return result;
}
Пример #6
0
  Result* nth_prototype(SEXP call, const ILazySubsets& subsets, int nargs) {
    // has to have at least two arguments
    if (nargs < 2) return 0;

    SEXP tag = TAG(CDR(call));
    if (tag != R_NilValue && tag != Rf_install("x")) {
      stop("the first argument of 'nth' should be either 'x' or unnamed");
    }
    SEXP data = CADR(call);
    if (TYPEOF(data) == SYMSXP) {
      if (! subsets.count(data)) {
        stop("could not find variable '%s'", CHAR(PRINTNAME(data)));
      }
      data = subsets.get_variable(data);
    }

    tag = TAG(CDDR(call));
    if (tag != R_NilValue && tag != Rf_install("n")) {
      stop("the second argument of 'first' should be either 'n' or unnamed");
    }
    SEXP nidx = CADDR(call);
    if ((TYPEOF(nidx) != REALSXP && TYPEOF(nidx) != INTSXP) || LENGTH(nidx) != 1) {
      // we only know how to handle the case where nidx is a length one
      // integer or numeric. In any other case, e.g. an expression for R to evaluate
      // we just fallback to R evaluation (#734)
      return 0;
    }
    int idx = as<int>(nidx);

    // easy case : just a single variable: first(x,n)
    if (nargs == 2) {
      switch (TYPEOF(data)) {
      case INTSXP:
        return new Nth<INTSXP>(data, idx);
      case REALSXP:
        return new Nth<REALSXP>(data, idx);
      case STRSXP:
        return new Nth<STRSXP>(data, idx);
      case LGLSXP:
        return new Nth<LGLSXP>(data, idx);
      default:
        break;
      }
    } else {
      // now get `order_by` and default

      SEXP order_by = R_NilValue;
      SEXP def    = R_NilValue;

      SEXP p = CDR(CDDR(call));
      while (p != R_NilValue) {
        SEXP tag = TAG(p);
        if (tag == R_NilValue) stop("all arguments of 'first' after the first one should be named");
        std::string argname = CHAR(PRINTNAME(tag));
        if (argmatch("order_by", argname)) {
          order_by = CAR(p);
        } else if (argmatch("default", argname)) {
          def = CAR(p);
        } else {
          stop("argument to 'first' does not match either 'default' or 'order_by' ");
        }

        p = CDR(p);
      }


      // handle cases
      if (def == R_NilValue) {

        // then we know order_by is not NULL, we only handle the case where
        // order_by is a symbol and that symbol is in the data
        if (TYPEOF(order_by) == SYMSXP && subsets.count(order_by)) {
          order_by = subsets.get_variable(order_by);

          switch (TYPEOF(data)) {
          case LGLSXP:
            return nth_with<LGLSXP>(data, idx, order_by);
          case INTSXP:
            return nth_with<INTSXP>(data, idx, order_by);
          case REALSXP:
            return nth_with<REALSXP>(data, idx, order_by);
          case STRSXP:
            return nth_with<STRSXP>(data, idx, order_by);
          default:
            break;
          }
        }
        else {
          return 0;
        }


      } else {
        if (order_by == R_NilValue) {
          switch (TYPEOF(data)) {
          case LGLSXP:
            return nth_noorder_default<LGLSXP>(data, idx, def);
          case INTSXP:
            return nth_noorder_default<INTSXP>(data, idx, def);
          case REALSXP:
            return nth_noorder_default<REALSXP>(data, idx, def);
          case STRSXP:
            return nth_noorder_default<STRSXP>(data, idx, def);
          default:
            break;
          }
        } else {
          if (TYPEOF(order_by) == SYMSXP && subsets.count(order_by)) {
            order_by = subsets.get_variable(order_by);

            switch (TYPEOF(data)) {
            case LGLSXP:
              return nth_with_default<LGLSXP>(data, idx, order_by, def);
            case INTSXP:
              return nth_with_default<INTSXP>(data, idx, order_by, def);
            case REALSXP:
              return nth_with_default<REALSXP>(data, idx, order_by, def);
            case STRSXP:
              return nth_with_default<STRSXP>(data, idx, order_by, def);
            default:
              break;
            }
          }
          else {
            return 0;
          }

        }
      }

    }
    stop("Unsupported vector type %s", Rf_type2char(TYPEOF(data)));
    return 0;
  }
Пример #7
0
 void CallProxy::set_call( SEXP call_ ){
     proxies.clear() ;
     call = call_ ;
     if( TYPEOF(call) == LANGSXP ) traverse_call(call) ;
 }
Пример #8
0
SEXP printNode(hpdRFnode *tree, int depth, int max_depth, SEXP classes)
{
#define tab     for(int i = 0; i < depth; i++) printf("\t")
  
  if(depth > max_depth)
    {
      tab;
	printf("Ommitting subtree\n");
	return R_NilValue;
    }
  
    double prediction = tree->prediction;
    tab;
    int index = (int) prediction;
    if(classes != R_NilValue && TYPEOF(classes) == STRSXP && 
       index >= 0 && index < length(classes))
      printf("<prediction> %s </prediction>\n",
	     CHAR(STRING_ELT(classes,(int)prediction)));
    else
      printf("<prediction> %f </prediction>\n", prediction);
    
    tab;
    printf("<deviance> %f </deviance>\n", tree->deviance);
    tab;
    printf("<complexity> %f </complexity>\n", tree->complexity);

    
    double* split_criteria = tree->split_criteria;
    int split_var=tree->split_variable;
    if(split_criteria != NULL)
      {
	tab;
	printf("<split_criteria> ");
	for(int i = 0; i < tree->split_criteria_length; i++)
	  printf("%f ",split_criteria[i]);
	printf("</split_criteria>\n");
	tab;
	printf("<split variable> %d </split variable>\n", split_var);
      }

    if(tree->additional_info)
      {

	tab;
	printf("leaf_id: %d\n", tree->additional_info->leafID);
	tab;
	printf("num_obs: %d\n", tree->additional_info->num_obs);

	
	tab;
	printf("indices: ");
	for(int i = 0; i < tree->additional_info->num_obs; i++)
	  printf("%d ", tree->additional_info->indices[i]);
	printf("\n");
	/*
	tab;
	printf("weights: ");
	for(int i = 0; i < tree->additional_info->num_obs; i++)
	  printf("%f ", tree->additional_info->weights[i]);
	printf("\n");
	*/
      }
    
    if(tree->left != NULL)
      {
	tab;
	printf("<Left Child Node>\n");
	printNode(tree->left, 
		  depth+1,max_depth,classes);
	tab;
	printf("</Left Child Node>\n");
      }
    if(tree->right != NULL)
      {
	tab;
	printf("<Right Child Node>\n");
	printNode(tree->right, 
		  depth+1,max_depth,classes);
	tab;
	printf("</Right Child Node>\n");
      }
    
    return R_NilValue;
  }
Пример #9
0
SEXP
R_tarExtract(SEXP r_filename,  SEXP r_filenames, SEXP r_fun, SEXP r_data,
             SEXP r_workBuf)
{
   TarExtractCallbackFun callback = R_tarCollectContents;
   RTarCallInfo rcb;
   Rboolean doRcallback = (TYPEOF(r_fun) == CLOSXP);
   void *data;

   gzFile *f = NULL;

   int numFiles = LENGTH(r_filenames), i;
   const char **argv;
   int argc = numFiles + 1;

   if(TYPEOF(r_filename) == STRSXP) {
       const char *filename;
       filename = CHAR(STRING_ELT(r_filename, 0));
       f = gzopen(filename, "rb");

       if(!f) {
	   PROBLEM "Can't open file %s", filename
	       ERROR;
       }
   }

   if(doRcallback) {

       SEXP p;

       rcb.rawData = r_workBuf;
       rcb.numProtects = 0;
       rcb.offset = 0;
				 

       PROTECT(rcb.e = p = allocVector( LANGSXP, 3));
       SETCAR(p, r_fun);

       callback = R_tarCollectContents;

       data = (void *) &rcb;

   } else {
       data = (void *) r_data;
       callback = (TarExtractCallbackFun) R_ExternalPtrAddr(r_fun);
   }

   argv = (char **) S_alloc(numFiles + 1, sizeof(char *));
   argv[0] = "R";
   for(i = 1; i < numFiles + 1; i++)
       argv[i] = CHAR(STRING_ELT(r_filenames, i-1));


   if(TYPEOF(r_filename) == STRSXP)
      tar(f, TGZ_EXTRACT, numFiles + 1, argc, argv, (TarCallbackFun) callback, (void *) data);
   else {
       DataSource src;
       R_rawStream stream;
       stream.data = RAW(r_filename);
       stream.len = LENGTH(r_filename);
       stream.pos = 0;

       src.data = &stream;
       src.throwError = rawError;
       src.read = rawRead;
       funTar(&src, TGZ_EXTRACT, numFiles + 1, argc, argv, (TarCallbackFun) callback, (void *) data);
   }

   if(doRcallback) 
       UNPROTECT(1);
   if(rcb.numProtects > 0)
       UNPROTECT(rcb.numProtects);

   if (f && gzclose(f) != Z_OK)
      error("failed gzclose");

   return(R_NilValue);
}
Пример #10
0
static jl_value_t *R_Julia_MD(SEXP Var, const char *VarName)
{

  if ((LENGTH(Var)) != 0)
  {
    jl_tuple_t *dims = RDims_JuliaTuple(Var);
    switch (TYPEOF( Var))
    {
    case LGLSXP:
    {
      jl_array_t *ret = CreateArray(jl_bool_type, jl_tuple_len(dims), dims);
      JL_GC_PUSH1(&ret);
      char *retData = (char *)jl_array_data(ret);
      for (size_t i = 0; i < jl_array_len(ret); i++)
        retData[i] = LOGICAL(Var)[i];
      jl_set_global(jl_main_module, jl_symbol(VarName), (jl_value_t *)ret);
      return (jl_value_t *) ret;
      JL_GC_POP();
      break;
    };
    case INTSXP:
    {
      jl_array_t *ret = CreateArray(jl_int32_type, jl_tuple_len(dims), dims);
      JL_GC_PUSH1(&ret);
      int *retData = (int *)jl_array_data(ret);
      for (size_t i = 0; i < jl_array_len(ret); i++)
        retData[i] = INTEGER(Var)[i];
      jl_set_global(jl_main_module, jl_symbol(VarName), (jl_value_t *)ret);
      return (jl_value_t *) ret;
      JL_GC_POP();
      break;
    }
    case REALSXP:
    {
      jl_array_t *ret = CreateArray(jl_float64_type, jl_tuple_len(dims), dims);
      JL_GC_PUSH1(&ret);
      double *retData = (double *)jl_array_data(ret);
      for (size_t i = 0; i < jl_array_len(ret); i++)
        retData[i] = REAL(Var)[i];
      jl_set_global(jl_main_module, jl_symbol(VarName), (jl_value_t *)ret);
      JL_GC_POP();
      return (jl_value_t *) ret;
      break;
    }
    case STRSXP:
    {
      jl_array_t *ret;
      if (!IS_ASCII(Var))
        ret = CreateArray(jl_utf8_string_type, jl_tuple_len(dims), dims);
      else
        ret = CreateArray(jl_ascii_string_type, jl_tuple_len(dims), dims);
      JL_GC_PUSH1(&ret);
      jl_value_t **retData = jl_array_data(ret);
      for (size_t i = 0; i < jl_array_len(ret); i++)
        if (!IS_ASCII(Var))
          retData[i] = jl_cstr_to_string(translateChar0(STRING_ELT(Var, i)));
        else
          retData[i] = jl_cstr_to_string(CHAR(STRING_ELT(Var, i)));
      jl_set_global(jl_main_module, jl_symbol(VarName), (jl_value_t *)ret);
      JL_GC_POP();
      return (jl_value_t *) ret;
      break;
    }
    case VECSXP:
    {
      char eltcmd[eltsize];
      jl_tuple_t *ret = jl_alloc_tuple(length(Var));
      JL_GC_PUSH1(&ret);
      for (int i = 0; i < length(Var); i++)
      {
        snprintf(eltcmd, eltsize, "%selement%d", VarName, i);
        jl_tupleset(ret, i, R_Julia_MD(VECTOR_ELT(Var, i), eltcmd));
      }
      jl_set_global(jl_main_module, jl_symbol(VarName), (jl_value_t *)ret);
      JL_GC_POP();
      return (jl_value_t *) ret;
    }
    default:
    {
      return (jl_value_t *) jl_nothing;
    }
    break;
    }
    return (jl_value_t *) jl_nothing;
  }
  return (jl_value_t *) jl_nothing;
}
Пример #11
0
SEXP R_initMethodDispatch(SEXP envir)
{
    if(envir && !isNull(envir))
	Methods_Namespace = envir;
    if(!Methods_Namespace)
	Methods_Namespace = R_GlobalEnv;
    if(initialized)
	return(envir);

    s_dot_Methods = install(".Methods");
    s_skeleton = install("skeleton");
    s_expression = install("expression");
    s_function = install("function");
    s_getAllMethods = install("getAllMethods");
    s_objectsEnv = install("objectsEnv");
    s_MethodsListSelect = install("MethodsListSelect");
    s_sys_dot_frame = install("sys.frame");
    s_sys_dot_call = install("sys.call");
    s_sys_dot_function = install("sys.function");
    s_generic = install("generic");
    s_generic_dot_skeleton = install("generic.skeleton");
    s_subset_gets = install("[<-");
    s_element_gets = install("[[<-");
    s_argument = install("argument");
    s_allMethods = install("allMethods");

    R_FALSE = ScalarLogical(FALSE);
    R_PreserveObject(R_FALSE);
    R_TRUE = ScalarLogical(TRUE);
    R_PreserveObject(R_TRUE);

    /* some strings (NOT symbols) */
    s_missing = mkString("missing");
    setAttrib(s_missing, R_PackageSymbol, mkString("methods"));
    R_PreserveObject(s_missing);
    s_base = mkString("base");
    R_PreserveObject(s_base);
    /*  Initialize method dispatch, using the static */
    R_set_standardGeneric_ptr(
	(table_dispatch_on ? R_dispatchGeneric : R_standardGeneric)
	, Methods_Namespace);
    R_set_quick_method_check(
	(table_dispatch_on ? R_quick_dispatch : R_quick_method_check));

    /* Some special lists of primitive skeleton calls.
       These will be promises under lazy-loading.
    */
    PROTECT(R_short_skeletons =
	    findVar(install(".ShortPrimitiveSkeletons"),
		    Methods_Namespace));
    if(TYPEOF(R_short_skeletons) == PROMSXP)
	R_short_skeletons = eval(R_short_skeletons, Methods_Namespace);
    R_PreserveObject(R_short_skeletons);
    UNPROTECT(1);
    PROTECT(R_empty_skeletons =
	    findVar(install(".EmptyPrimitiveSkeletons"),
		    Methods_Namespace));
    if(TYPEOF(R_empty_skeletons) == PROMSXP)
	R_empty_skeletons = eval(R_empty_skeletons, Methods_Namespace);
    R_PreserveObject(R_empty_skeletons);
    UNPROTECT(1);
    if(R_short_skeletons == R_UnboundValue ||
       R_empty_skeletons == R_UnboundValue)
	error(_("could not find the skeleton calls for 'methods' (package detached?): expect very bad things to happen"));
    f_x_i_skeleton = VECTOR_ELT(R_short_skeletons, 0);
    fgets_x_i_skeleton = VECTOR_ELT(R_short_skeletons, 1);
    f_x_skeleton = VECTOR_ELT(R_empty_skeletons, 0);
    fgets_x_skeleton = VECTOR_ELT(R_empty_skeletons, 1);
    init_loadMethod();
    initialized = 1;
    return(envir);
}
Пример #12
0
static jl_value_t *R_Julia_MD_NA(SEXP Var, const char *VarName)
{
  if ((LENGTH(Var)) != 0)
  {
    jl_tuple_t *dims = RDims_JuliaTuple(Var);

    switch (TYPEOF(Var))
    {
    case LGLSXP:
    {
      jl_array_t *ret = CreateArray(jl_bool_type, jl_tuple_len(dims), dims);
      jl_array_t *ret1 = CreateArray(jl_bool_type, jl_tuple_len(dims), dims);
      JL_GC_PUSH(&ret, &ret1);

      char *retData = (char *)jl_array_data(ret);
      bool *retData1 = (bool *)jl_array_data(ret1);
      for (size_t i = 0; i < jl_array_len(ret); i++)
      {
        if (LOGICAL(Var)[i] == NA_LOGICAL)
        {
          retData[i] = 1;
          retData1[i] = true;
        }
        else
        {
          retData[i] = LOGICAL(Var)[i];
          retData1[i] = false;
        }
      }
      JL_GC_POP();
      return TransArrayToDataArray(ret, ret1, VarName);
      break;
    };
    case INTSXP:
    {
      jl_array_t *ret = CreateArray(jl_int32_type, jl_tuple_len(dims), dims);
      jl_array_t *ret1 = CreateArray(jl_bool_type, jl_tuple_len(dims), dims);
      JL_GC_PUSH(&ret, &ret1);

      int *retData = (int *)jl_array_data(ret);
      bool *retData1 = (bool *)jl_array_data(ret1);
      for (size_t i = 0; i < jl_array_len(ret); i++)
      {
        if (INTEGER(Var)[i] == NA_INTEGER)
        {
          retData[i] = 999;
          retData1[i] = true;
        }
        else
        {
          retData[i] = INTEGER(Var)[i];
          retData1[i] = false;
        }
      }
      JL_GC_POP();
      return TransArrayToDataArray(ret, ret1, VarName);
      break;
    }
    case REALSXP:
    {
      jl_array_t *ret = CreateArray(jl_float64_type, jl_tuple_len(dims), dims);
      jl_array_t *ret1 = CreateArray(jl_bool_type, jl_tuple_len(dims), dims);
      JL_GC_PUSH(&ret, &ret1);
      double *retData = (double *)jl_array_data(ret);
      bool *retData1 = (bool *)jl_array_data(ret1);
      for (size_t i = 0; i < jl_array_len(ret); i++)
      {
        if (ISNAN(REAL(Var)[i]))
        {
          retData[i] = 999.01;
          retData1[i] = true;
        }
        else
        {
          retData[i] = REAL(Var)[i];
          retData1[i] = false;
        }
      }
      JL_GC_POP();
      return TransArrayToDataArray(ret, ret1, VarName);
      break;
    }
    case STRSXP:
    {
      jl_array_t *ret;
      if (!IS_ASCII(Var))
        ret = CreateArray(jl_utf8_string_type, jl_tuple_len(dims), dims);
      else
        ret = CreateArray(jl_ascii_string_type, jl_tuple_len(dims), dims);

      jl_array_t *ret1 = CreateArray(jl_bool_type, jl_tuple_len(dims), dims);

      JL_GC_PUSH(&ret, &ret1);
      jl_value_t **retData = jl_array_data(ret);
      bool *retData1 = (bool *)jl_array_data(ret1);
      for (size_t i = 0; i < jl_array_len(ret); i++)
      {
        if (STRING_ELT(Var, i) == NA_STRING)
        {
          retData[i] = jl_cstr_to_string("999");
          retData1[i] = true;
        }
        else
        {
          if (!IS_ASCII(Var))
            retData[i] = jl_cstr_to_string(translateChar0(STRING_ELT(Var, i)));
          else
            retData[i] = jl_cstr_to_string(CHAR(STRING_ELT(Var, i)));
          retData1[i] = false;
        }
      }
      JL_GC_POP();
      return TransArrayToDataArray(ret, ret1, VarName);
      break;
    }
    default:
      return (jl_value_t *) jl_nothing;
      break;
    }//case end
    return (jl_value_t *) jl_nothing;
  }//if length !=0
  return (jl_value_t *) jl_nothing;
}
Пример #13
0
SEXP R_export2dataset(SEXP path, SEXP dataframe, SEXP shape, SEXP shape_info)
{
  std::wstring dataset_name;
  tools::copy_to(path, dataset_name);

  struct _cleanup
  {
    typedef std::vector<cols_base*> c_type;
    std::vector<std::wstring> name;
    c_type c;
    //std::vector<c_type::const_iterator> shape;
    c_type shape;
    ~_cleanup()
    {
      for (size_t i = 0; i < c.size(); i++)
        delete c[i];
      for (size_t i = 0; i < shape.size(); i++)
        delete shape[i];
    }
  }cols;

  shape_extractor extractor;
  bool isShape = extractor.init(shape, shape_info) == S_OK;
  //SEXP sinfo = Rf_getAttrib(shape, Rf_mkChar("shape_info"));
  //cols.name = df.attr("names");
  tools::getNames(dataframe, cols.name);
  
  //tools::vectorGeneric shape_info(sinfo);
  //std::string gt_type;
  //tools::copy_to(shape_info.at("type"), gt_type);
  esriGeometryType gt = extractor.type();//str2geometryType(gt_type.c_str());
  R_xlen_t n = 0;

  ATLTRACE("dataframe type:%s", Rf_type2char(TYPEOF(dataframe)));

  if (Rf_isVectorList(dataframe))
  {
    size_t k = tools::size(dataframe);
    cols.name.resize(k);
    for (size_t i = 0; i < k; i++)
    {
      n = std::max(n, tools::size(VECTOR_ELT(dataframe, (R_xlen_t)i)));
      if (cols.name[i].empty())
        cols.name[i] = L"data";
    }
  }
  else
  {
    n = tools::size(dataframe);
    ATLASSERT(cols.name.empty());
  }

  if (isShape == false && n == 0)
    return showError<false>(L"nothing to save"), R_NilValue;

  if (isShape && n != extractor.size() )
    return showError<false>(L"length of shape != data.frame"), R_NilValue;

  CComPtr<IGPUtilities> ipDEUtil;
  if (ipDEUtil.CoCreateInstance(CLSID_GPUtilities) != S_OK)
    return showError<true>(L"IDEUtilitiesImpl - CoCreateInstance has failed"), R_NilValue;

  HRESULT hr = 0;

  CComPtr<IName> ipName;
  if (isShape)
    hr = ipDEUtil->CreateFeatureClassName(CComBSTR(dataset_name.c_str()), &ipName);
  else
    hr = ipDEUtil->CreateTableName(CComBSTR(dataset_name.c_str()), &ipName);

  CComQIPtr<IDatasetName> ipDatasetName(ipName);
  CComPtr<IWorkspaceName> ipWksName;
  CComQIPtr<IWorkspace> ipWks;
  if (hr == S_OK)
    hr = ipDatasetName->get_WorkspaceName(&ipWksName);
  if (hr == S_OK)
  {
    CComPtr<IUnknown> ipUnk;
    hr = CComQIPtr<IName>(ipWksName)->Open(&ipUnk);
    ipWks = ipUnk;
  }

  if (hr != S_OK)
    return showError<true>(L"invalid table name"), R_NilValue;
  
  CComQIPtr<IFeatureWorkspace> ipFWKS(ipWks);
  ATLASSERT(ipFWKS);
  if (!ipFWKS)
    return showError<true>(L"not a FeatureWorkspace"), R_NilValue;
  
  CComBSTR bstrTableName;
  ipDatasetName->get_Name(&bstrTableName);

  CComPtr<IFieldsEdit> ipFields;
  hr = ipFields.CoCreateInstance(CLSID_Fields);
  if (hr != S_OK) return showError<true>(L"CoCreateInstance"), R_NilValue;

  createField(NULL, esriFieldTypeOID, ipFields);

  CComPtr<ISpatialReference> ipSR;

  if (isShape)
  {
    long pos = createField(NULL, esriFieldTypeGeometry, ipFields);
    CComPtr<IGeometryDef> ipGeoDef;
    CComPtr<IField> ipField;
    ipFields->get_Field(pos, &ipField);
    ipField->get_GeometryDef(&ipGeoDef);
    
    CComQIPtr<IGeometryDefEdit> ipGeoDefEd(ipGeoDef);
    ipGeoDefEd->put_GeometryType(gt);
    ipGeoDefEd->putref_SpatialReference(extractor.sr());
  }

  if (cols.name.empty())
  {
    cols.name.push_back(L"data");
    cols_base* item = setup_field(ipFields, dataframe, cols.name[0].c_str());
    if (!item)
      return showError<false>(L"unsupported datat.field column type"), NULL;
    cols.c.push_back(item);
    item->name_ref = &cols.name[0];
  }
  else
    for (size_t i = 0; i < cols.name.size(); i++)
    {
      if (cols.name[i].empty())
        continue;
      const wchar_t* str = cols.name[i].c_str();
      SEXP it = VECTOR_ELT(dataframe, (R_len_t)i);
      cols_base* item = setup_field(ipFields, it, str);
      if (!item)
        return showError<false>(L"unsupported datat.field column type"), NULL;
      cols.c.push_back(item);
      item->name_ref = &cols.name[i];
    }

  CComPtr<IFieldChecker> ipFieldChecker; ipFieldChecker.CoCreateInstance(CLSID_FieldChecker);  
  if (ipFieldChecker)
  {
    ipFieldChecker->putref_ValidateWorkspace(ipWks);
    long error = 0;

    //fix fields names
    CComPtr<IFields> ipFixedFields;
    
    CComPtr<IEnumFieldError> ipEError;
    hr = ipFieldChecker->Validate(ipFields, &ipEError, &ipFixedFields);
    if (hr != S_OK)
      return showError<true>(L"validate fields failed"), NULL;
  
    if (ipFixedFields)
    {
      ipFields = ipFixedFields;
      for (size_t c = 0; c < cols.c.size(); c++)
      {
        CComPtr<IField> ipFixedField;
        ipFixedFields->get_Field(cols.c[c]->pos, &ipFixedField);
        _bstr_t name;
        ipFixedField->get_Name(name.GetAddress());
        cols.c[c]->name_ref->assign(name);
      }
    }
  }

  CComPtr<IUID> ipUID; ipUID.CoCreateInstance(CLSID_UID);
  if (ipUID)
  {
    OLECHAR buf[256];
    ::StringFromGUID2(isShape ? CLSID_Feature : CLSID_Row, buf, 256);
    ipUID->put_Value(CComVariant(buf));
  }

  CComQIPtr<ITable> ipTableNew;
  CComBSTR keyword(L"");
  hr = E_FAIL;
  if (isShape)
  {
    CComPtr<IFeatureClass> ipFClass;
    hr = ipFWKS->CreateFeatureClass(bstrTableName, ipFields, ipUID, 0, esriFTSimple, CComBSTR(L"Shape"), keyword, &ipFClass);
    ipTableNew = ipFClass;
  }
  else
  {
    hr = ipFWKS->CreateTable(bstrTableName, ipFields, ipUID, 0, keyword, &ipTableNew);
  }
  if (hr != S_OK)
  {
    std::wstring err_txt(isShape ? L"Create FeatureClass :" : L"Create Table :");
    err_txt += bstrTableName;
    err_txt += L" has failed";
    return showError<true>(err_txt.c_str()), R_NilValue;
  }

  CComVariant oid;

  CComPtr<ICursor> ipCursor;
  CComPtr<IRowBuffer> ipRowBuffer;
  hr = ipTableNew->Insert(VARIANT_TRUE, &ipCursor);
  if (hr != S_OK)
    return showError<true>(L"Insert cursor failed"), R_NilValue;
  hr = ipTableNew->CreateRowBuffer(&ipRowBuffer);
  if (hr != S_OK)
    return showError<true>(L"Insert cursor failed"), R_NilValue;
  
  //re-map fields
  CComPtr<IFields> ipRealFields;
  ipCursor->get_Fields(&ipRealFields);
  for (size_t c = 0; c < cols.c.size(); c++)
  {
    ipRealFields->FindField(CComBSTR(cols.c[c]->name_ref->c_str()), &(cols.c[c]->pos));
    CComPtr<IField> ipField;
    ipRealFields->get_Field(cols.c[c]->pos, &ipField);
    VARIANT_BOOL b = VARIANT_FALSE;
    ipField->get_IsNullable(&b);
    if (b == VARIANT_FALSE)
    {
      esriFieldType ft = esriFieldTypeInteger;
      ipField->get_Type(&ft);
      switch(ft)
      {
        case esriFieldTypeInteger:
          cols.c[c]->vNULL = 0;//std::numeric_limits<int>::min();
          break;
        case esriFieldTypeDouble:
          cols.c[c]->vNULL = 0.0;//-std::numeric_limits<double>::max();
          break;
        case esriFieldTypeString:
          cols.c[c]->vNULL = L"";
      }
    }
  }

  CComQIPtr<IFeatureBuffer> ipFBuffer(ipRowBuffer);
  for (R_len_t i = 0; i < n; i++)
  {
    //ATLTRACE("\n");
    for (size_t c = 0; c < cols.c.size(); c++)
    {
      if (cols.c[c]->pos < 0)
        continue;
      CComVariant val;
      cols.c[c]->get(i, val);
      if (val.vt == VT_NULL)
        hr = ipRowBuffer->put_Value(cols.c[c]->pos, cols.c[c]->vNULL);
      else
        hr = ipRowBuffer->put_Value(cols.c[c]->pos, val);
      if (FAILED(hr))
        return showError<true>(L"insert row value failed"), R_NilValue;
    }
    VARIANT oid;

    if (isShape)
    {
      ATLASSERT(ipFBuffer);
      CComQIPtr<IGeometry> ipNewShape;
      hr = extractor.at(i, &ipNewShape);
      if (hr != S_OK)
        return R_NilValue;

      hr = ipFBuffer->putref_Shape(ipNewShape);
      if (FAILED(hr))
        return showError<true>(L"insert shape failed"), R_NilValue;
    }

    hr = ipCursor->InsertRow(ipRowBuffer, &oid);
    if (hr != S_OK)
      return showError<true>(L"insert row failed"), R_NilValue;
  }
  return R_NilValue;
}
Пример #14
0
SEXP R_dataframe2dataset(SEXP dtaframe, SEXP path, SEXP shape_columns)
{
  if (!Rf_isFrame(dtaframe))
    return showError<false>(L"argument 0 is not a data.frame"), R_NilValue;
//same as narray_tools.cpp
  std::wstring dataset_name;
  tools::copy_to(path, dataset_name);

  struct _cleanup
  {
    typedef std::vector<cols_base*> c_type;
    std::vector<std::string> name;
    c_type c;
    //std::vector<c_type::const_iterator> shape;
    c_type shape;
    ~_cleanup()
    {
      for (size_t i = 0; i < c.size(); i++)
        delete c[i];
      for (size_t i = 0; i < shape.size(); i++)
        delete shape[i];
    }
  }cols;

  //cols.name = df.attr("names");
  tools::getNames(dtaframe, cols.name);

  if (cols.name.empty())
    return showError<false>(L"data.frame has 0 column"), R_NilValue;
  if (tools::size(dtaframe) != cols.name.size())
    return showError<false>(L"unknown"), R_NilValue;

  CComPtr<IGPUtilities> ipDEUtil;
  if (ipDEUtil.CoCreateInstance(CLSID_GPUtilities) != S_OK)
    return showError<true>(L"IDEUtilitiesImpl - CoCreateInstance has failed"), R_NilValue;
  HRESULT hr;

  //cols.c.resize(cols.name.size(), NULL);

  bool isShape = false;
  if (shape_columns != R_NilValue)
  {
    std::vector<std::string> shapes;
    tools::copy_to(shape_columns, shapes);
    if (shapes.size() < 2 || shapes.size() > 4)
      return showError<false>(L"shape expecting 2 strings"), NULL;
    isShape = true;
    for (size_t i = 0; i < shapes.size(); i++)
    {
      std::vector<std::string>::iterator it = std::find(cols.name.begin(), cols.name.end(), shapes[i]);
      if (it == cols.name.end())
        return showError<false>(L"cannot find shape in data.frame"), NULL;

      size_t pos = std::distance(cols.name.begin(), it);
      cols.shape.push_back(new cols_wrap<double>(VECTOR_ELT(dtaframe, pos)));
      //cols.shape.[i] = cols.c.begin() + pos;
      it->clear();
    }
  }


  CComPtr<IName> ipName;
  if (isShape)
    hr = ipDEUtil->CreateFeatureClassName(CComBSTR(dataset_name.c_str()), &ipName);
  else
    hr = ipDEUtil->CreateTableName(CComBSTR(dataset_name.c_str()), &ipName);

  CComQIPtr<IDatasetName> ipDatasetName(ipName);
  CComPtr<IWorkspaceName> ipWksName;
  CComQIPtr<IWorkspace> ipWks;
  if (hr == S_OK)
    hr = ipDatasetName->get_WorkspaceName(&ipWksName);
  if (hr == S_OK)
  {
    CComPtr<IUnknown> ipUnk;
    hr = CComQIPtr<IName>(ipWksName)->Open(&ipUnk);
    ipWks = ipUnk;
  }

  if (hr != S_OK)
    return showError<true>(L"invalid table name"), R_NilValue;

  CComQIPtr<IFeatureWorkspace> ipFWKS(ipWks);
  ATLASSERT(ipFWKS);
  if (!ipFWKS)
    return showError<true>(L"not a FeatureWorkspace"), R_NilValue;

  CComBSTR bstrTableName;
  ipDatasetName->get_Name(&bstrTableName);
  /*
  CComQIPtr<IWorkspaceSchemaImpl> ipWSchema(ipWks);
  if (ipWSchema)
  {
    VARIANT_BOOL b = VARIANT_FALSE;
    ipWSchema->TableExists(bstrTableName, &b);
    if (b != VARIANT_FALSE)
      return ::Rf_error("table Exists"), NULL;
  }*/

  CComPtr<IFieldsEdit> ipFields;
  hr = ipFields.CoCreateInstance(CLSID_Fields);
  if (hr != S_OK) return showError<true>(L"CoCreateInstance"), R_NilValue;
  
  //if (!createField(NULL, esriFieldTypeOID, ipFields))
  //  return NULL;
  if (isShape)
  {
    long pos = createField(NULL, esriFieldTypeGeometry, ipFields);
    CComPtr<IGeometryDef> ipGeoDef;
    CComPtr<IField> ipField;
    ipFields->get_Field(pos, &ipField);
    ipField->get_GeometryDef(&ipGeoDef);
    CComQIPtr<IGeometryDefEdit> ipGeoDefEd(ipGeoDef);
    ipGeoDefEd->put_GeometryType(esriGeometryPoint);
    CComQIPtr<ISpatialReference> ipSR(g_lastUsedSR);
    if (!ipSR)
    {
      ipSR.CoCreateInstance(CLSID_UnknownCoordinateSystem);
      CComQIPtr<ISpatialReferenceResolution> ipSRR(ipSR);
      if (ipSRR) FIX_DEFAULT_SR(ipSRR);
    }
    ipGeoDefEd->putref_SpatialReference(ipSR);
  }


  for (size_t i = 0; i < cols.name.size(); i++)
  {
    if (cols.name[i].empty())
      continue;
    const char* str = cols.name[i].c_str();
    cols_base* item = NULL;
    SEXP it = VECTOR_ELT(dtaframe, i);
    switch (TYPEOF(it))
    {
       case NILSXP: case SYMSXP: case RAWSXP: case LISTSXP:
       case CLOSXP: case ENVSXP: case PROMSXP: case LANGSXP:
       case SPECIALSXP: case BUILTINSXP:
       case CPLXSXP: case DOTSXP: case ANYSXP: case VECSXP:
       case EXPRSXP: case BCODESXP: case EXTPTRSXP: case WEAKREFSXP:
       case S4SXP:
       default:
          return showError<false>(L"unsupported datat.field column type"), NULL;
       case INTSXP:
         item = new cols_wrap<int>(it);
         item->pos = createField(str, esriFieldTypeInteger, ipFields); 
         break;
       case REALSXP: 
         item = new cols_wrap<double>(it);
         item->pos = createField(str, esriFieldTypeDouble, ipFields); 
         break;
       case STRSXP:
       case CHARSXP:
         item = new cols_wrap<std::string>(it);
         item->pos = createField(str, esriFieldTypeString, ipFields);
         break;
       case LGLSXP: 
         item = new cols_wrap<bool>(it);
         item->pos = createField(str, esriFieldTypeInteger, ipFields);
         break;
    }
    ATLASSERT(item);
    cols.c.push_back(item);
    item->name_ref = &cols.name[i];
  }

  CComPtr<IFieldChecker> ipFieldChecker; ipFieldChecker.CoCreateInstance(CLSID_FieldChecker);  
  if (ipFieldChecker)
  {
    ipFieldChecker->putref_ValidateWorkspace(ipWks);
    long error = 0;

    //fix fields names
    CComPtr<IFields> ipFixedFields;
    
    CComPtr<IEnumFieldError> ipEError;
    hr = ipFieldChecker->Validate(ipFields, &ipEError, &ipFixedFields);
    if (hr != S_OK)
      return showError<true>(L"validate fields failed"), NULL;
  
    if (ipFixedFields)
    {
      ipFields = ipFixedFields;
      for (size_t c = 0; c < cols.c.size(); c++)
      {
        CComPtr<IField> ipFixedField;
        ipFixedFields->get_Field(cols.c[c]->pos, &ipFixedField);
        _bstr_t name;
        ipFixedField->get_Name(name.GetAddress());
        cols.c[c]->name_ref->assign(name);
      }
    }
  }

  CComPtr<IUID> ipUID; ipUID.CoCreateInstance(CLSID_UID);
  CComQIPtr<ITable> ipTableNew;
  CComBSTR keyword(L"");
  hr = E_FAIL;
  if (isShape)
  {
    if (ipUID)
    {
      OLECHAR buf[256];
      ::StringFromGUID2(CLSID_Feature, buf, 256);
      ipUID->put_Value(CComVariant(buf));
    }

    CComPtr<IFeatureClass> ipFClass;
    hr = ipFWKS->CreateFeatureClass(bstrTableName, ipFields, ipUID, 0, esriFTSimple, CComBSTR(L"Shape"), keyword, &ipFClass);
    ipTableNew = ipFClass;
  }
  else
  {
    if (ipUID)
    {
      OLECHAR buf[256];
      ::StringFromGUID2(CLSID_Row, buf, 256);
      ipUID->put_Value(CComVariant(buf));
    }
    hr = ipFWKS->CreateTable(bstrTableName, ipFields, ipUID, 0, keyword, &ipTableNew);
  }

  if (hr != S_OK)
    return showError<true>(L"validate fields failed"), R_NilValue;

  CComVariant oid;
 
  CComPtr<ICursor> ipCursor;
  CComPtr<IRowBuffer> ipRowBuffer;
  hr = ipTableNew->Insert(VARIANT_TRUE, &ipCursor);
  if (hr != S_OK)
    return showError<true>(L"Insert cursor failed"), R_NilValue;
  hr = ipTableNew->CreateRowBuffer(&ipRowBuffer);
  if (hr != S_OK)
    return showError<true>(L"Insert cursor failed"), R_NilValue;
  
  //re-map fields
  for (size_t c = 0; c < cols.c.size(); c++)
    ipCursor->FindField(CComBSTR(cols.c[c]->name_ref->c_str()), &(cols.c[c]->pos));

  R_len_t n = tools::size(VECTOR_ELT(dtaframe, 0));
  for (R_len_t i = 0; i < n; i++)
  {
    //ATLTRACE("\n");
    for (size_t c = 0; c < cols.c.size(); c++)
    {
      if (cols.c[c]->pos < 0)
        continue;
      CComVariant val;
      cols.c[c]->get(i, val);
      hr = ipRowBuffer->put_Value(cols.c[c]->pos, val);
      if (hr != S_OK)
        return showError<true>(L"insert row value failed"), R_NilValue;
      //ATLTRACE(" [%i]=%f",cols[c]->pos, (float)val.dblVal);
    }
    VARIANT oid;
    
    if (isShape)
    {
      CComQIPtr<IPoint> ipPoint; ipPoint.CoCreateInstance(CLSID_Point);
      CComVariant valX, valY;
      cols.shape[0]->get(i, valX);
      cols.shape[1]->get(i, valY);
      ipPoint->PutCoords(valX.dblVal, valY.dblVal);
      CComQIPtr<IFeatureBuffer> ipFBuffer(ipRowBuffer);
      ATLASSERT(ipFBuffer);
      hr = ipFBuffer->putref_Shape(ipPoint);
      if (hr != S_OK)
        return showError<true>(L"insert shape failed"), R_NilValue;
    }

    hr = ipCursor->InsertRow(ipRowBuffer, &oid);
    if (hr != S_OK)
      return showError<true>(L"insert row failed"), R_NilValue;
  }
  return R_NilValue;
}
Пример #15
0
SEXP attribute_hidden
do_mapply(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    checkArity(op, args);

    SEXP f = CAR(args), varyingArgs = CADR(args), constantArgs = CADDR(args);
    int m, zero = 0;
    R_xlen_t *lengths, *counters, longest = 0;

    m = length(varyingArgs);
    SEXP vnames = PROTECT(getAttrib(varyingArgs, R_NamesSymbol));
    Rboolean named = CXXRCONSTRUCT(Rboolean, vnames != R_NilValue);

    lengths = static_cast<R_xlen_t *>(  CXXR_alloc(m, sizeof(R_xlen_t)));
    for (int i = 0; i < m; i++) {
	SEXP tmp1 = VECTOR_ELT(varyingArgs, i);
	lengths[i] = xlength(tmp1);
	if (isObject(tmp1)) { // possibly dispatch on length()
	    /* Cache the .Primitive: unclear caching is worthwhile. */
	    static SEXP length_op = NULL;
	    if (length_op == NULL) length_op = R_Primitive("length");
	    // DispatchOrEval() needs 'args' to be a pairlist
	    SEXP ans, tmp2 = PROTECT(list1(tmp1));
	    if (DispatchOrEval(call, length_op, "length", tmp2, rho, &ans, 0, 1))
		lengths[i] = R_xlen_t( (TYPEOF(ans) == REALSXP ?
					REAL(ans)[0] : asInteger(ans)));
	    UNPROTECT(1);
	}
	if (lengths[i] == 0) zero++;
	if (lengths[i] > longest) longest = lengths[i];
    }
    if (zero && longest)
	error(_("zero-length inputs cannot be mixed with those of non-zero length"));

    counters = static_cast<R_xlen_t *>( CXXR_alloc(m, sizeof(R_xlen_t)));
    memset(counters, 0, m * sizeof(R_xlen_t));

    SEXP mindex = PROTECT(allocVector(VECSXP, m));
    SEXP nindex = PROTECT(allocVector(VECSXP, m));

    /* build a call like
       f(dots[[1]][[4]], dots[[2]][[4]], dots[[3]][[4]], d=7)
    */

    SEXP fcall = R_NilValue; // -Wall
    if (constantArgs == R_NilValue)
	;
    else if (isVectorList(constantArgs))
	fcall = VectorToPairList(constantArgs);
    else
	error(_("argument 'MoreArgs' of 'mapply' is not a list"));
    PROTECT_INDEX fi;
    PROTECT_WITH_INDEX(fcall, &fi);

    Rboolean realIndx = CXXRCONSTRUCT(Rboolean, longest > INT_MAX);
    SEXP Dots = install("dots");
    for (int j = m - 1; j >= 0; j--) {
	SET_VECTOR_ELT(mindex, j, ScalarInteger(j + 1));
	SET_VECTOR_ELT(nindex, j, allocVector(realIndx ? REALSXP : INTSXP, 1));
	SEXP tmp1 = PROTECT(lang3(R_Bracket2Symbol, Dots, VECTOR_ELT(mindex, j)));
	SEXP tmp2 = PROTECT(lang3(R_Bracket2Symbol, tmp1, VECTOR_ELT(nindex, j)));
	REPROTECT(fcall = CONS(tmp2, fcall), fi);
	UNPROTECT(2);
	if (named && CHAR(STRING_ELT(vnames, j))[0] != '\0')
	    SET_TAG(fcall, installTrChar(STRING_ELT(vnames, j)));
    }

    REPROTECT(fcall = LCONS(f, fcall), fi);

    SEXP ans = PROTECT(allocVector(VECSXP, longest));

    for (int i = 0; i < longest; i++) {
	for (int j = 0; j < m; j++) {
	    counters[j] = (++counters[j] > lengths[j]) ? 1 : counters[j];
	    if (realIndx)
		REAL(VECTOR_ELT(nindex, j))[0] = double( counters[j]);
	    else
		INTEGER(VECTOR_ELT(nindex, j))[0] = int( counters[j]);
	}
	SEXP tmp = eval(fcall, rho);
	if (NAMED(tmp))
	    tmp = duplicate(tmp);
	SET_VECTOR_ELT(ans, i, tmp);
    }

    for (int j = 0; j < m; j++)
	if (counters[j] != lengths[j])
	    warning(_("longer argument not a multiple of length of shorter"));

    UNPROTECT(5);
    return ans;
}
Пример #16
0
SEXP
R_tarInfo(SEXP r_filename,  SEXP r_fun, SEXP r_data)
{
   gzFile *f = NULL;
   const char *filename;
   char *argv[] = {"R"};
   TarCallbackFun callback = R_tarInfo_callback;
   RTarCallInfo rcb;
   Rboolean doRcallback = (TYPEOF(r_fun) == CLOSXP);
   void *data;

   if(TYPEOF(r_filename) == STRSXP) {
       filename = CHAR(STRING_ELT(r_filename, 0));
       f = gzopen(filename, "rb");

       if(!f) {
	   PROBLEM "Can't open file %s", filename
	       ERROR;
       }
   }

   if(doRcallback) {

       SEXP p;
       PROTECT(rcb.e = p = allocVector(LANGSXP, 6));
       SETCAR(p, r_fun); p = CDR(p);
       SETCAR(p, allocVector(STRSXP, 1)); p = CDR(p); /* file */
       SETCAR(p, mkString("a")); p = CDR(p); /* type flag */
       SETCAR(p, allocVector(REALSXP, 1)); p = CDR(p); /* time */
       SETCAR(p, allocVector(INTSXP, 1)); p = CDR(p); /* remaining */
       SETCAR(p, allocVector(INTSXP, 1)); p = CDR(p); /* counter */

       data = (void *) &rcb;

   } else {

       data = (void *) r_data;
       callback = (TarCallbackFun) R_ExternalPtrAddr(r_fun);

   }

   if(f) {
       tar(f, TGZ_LIST, 1, sizeof(argv)/sizeof(argv[0]), argv, callback, (void *) data);
   } else {
       DataSource src;
       R_rawStream stream;
       stream.data = RAW(r_filename);
       stream.len = LENGTH(r_filename);
       stream.pos = 0;

       src.data = &stream;
       src.throwError = rawError;
       src.read = rawRead;
       funTar(&src, TGZ_LIST, 1, sizeof(argv)/sizeof(argv[0]), argv, callback, (void *) data);
   }

   if(doRcallback) 
       UNPROTECT(1);

   if (f && gzclose(f) != Z_OK)
      error("failed gzclose");

   return(R_NilValue);
}
Пример #17
0
static void extractItem(char *buffer, SEXP ans, int i, LocalData *d)
{
    char *endp;
    switch(TYPEOF(ans)) {
    case NILSXP:
	break;
    case LGLSXP:
	if (isNAstring(buffer, 0, d))
	    LOGICAL(ans)[i] = NA_INTEGER;
	else {
	    int tr = StringTrue(buffer), fa = StringFalse(buffer);
	    if(tr || fa) LOGICAL(ans)[i] = tr;
	    else expected("a logical", buffer, d);
	}
	break;
    case INTSXP:
	if (isNAstring(buffer, 0, d))
	    INTEGER(ans)[i] = NA_INTEGER;
	else {
	    INTEGER(ans)[i] = Strtoi(buffer, 10);
	    if (INTEGER(ans)[i] == NA_INTEGER)
		expected("an integer", buffer, d);
	}
	break;
    case REALSXP:
	if (isNAstring(buffer, 0, d))
	    REAL(ans)[i] = NA_REAL;
	else {
	    REAL(ans)[i] = Strtod(buffer, &endp, TRUE, d);
	    if (!isBlankString(endp))
		expected("a real", buffer, d);
	}
	break;
    case CPLXSXP:
	if (isNAstring(buffer, 0, d))
	    COMPLEX(ans)[i].r = COMPLEX(ans)[i].i = NA_REAL;
	else {
	    COMPLEX(ans)[i] = strtoc(buffer, &endp, TRUE, d);
	    if (!isBlankString(endp))
		expected("a complex", buffer, d);
	}
	break;
    case STRSXP:
	if (isNAstring(buffer, 1, d))
	    SET_STRING_ELT(ans, i, NA_STRING);
	else
	    SET_STRING_ELT(ans, i, insertString(buffer, d));
	break;
    case RAWSXP:
	if (isNAstring(buffer, 0, d))
	    RAW(ans)[i] = 0;
	else {
	    RAW(ans)[i] = strtoraw(buffer, &endp);
	    if (!isBlankString(endp))
		expected("a raw", buffer, d);
	}
	break;
    default:
	UNIMPLEMENTED_TYPE("extractItem", ans);
    }
}
Пример #18
0
Rboolean Rf_isReal(SEXP x) {
    return TYPEOF(x) == REALSXP;
}
Пример #19
0
/*! @decl int bind(int|string port, void|function accept_callback, @
 *!                void|string ip, void|string reuse_port)
 *!
 *! Opens a socket and binds it to port number on the local machine.
 *! If the second argument is present, the socket is set to
 *! nonblocking and the callback funcition is called whenever
 *! something connects to it. The callback will receive the id for
 *! this port as argument and should typically call @[accept] to
 *! establish a connection.
 *!
 *! If the optional argument @[ip] is given, @[bind] will try to bind
 *! to an interface with that host name or IP number. Omitting this
 *! will bind to all available IPv4 addresses; specifying "::" will
 *! bind to all IPv4 and IPv6 addresses.
 *!
 *! If the OS supports TCP_FASTOPEN it is enabled automatically.
 *!
 *! If the OS supports SO_REUSEPORT it is enabled if the fourth argument is true.
 *!
 *! @returns
 *!   1 is returned on success, zero on failure. @[errno] provides
 *!   further details about the error in the latter case.
 *!
 *! @seealso
 *!   @[accept], @[set_id]
 */
static void port_bind(INT32 args)
{
  struct port *p = THIS;
  PIKE_SOCKADDR addr;
  int addr_len,fd,tmp;

  do_close(p);

  if(args < 1)
    SIMPLE_WRONG_NUM_ARGS_ERROR("bind", 1);

  if(TYPEOF(Pike_sp[-args]) != PIKE_T_INT &&
     (TYPEOF(Pike_sp[-args]) != PIKE_T_STRING ||
      Pike_sp[-args].u.string->size_shift))
    SIMPLE_ARG_TYPE_ERROR("bind", 1, "int|string(8bit)");

  addr_len = get_inet_addr(&addr,
                           (args > 2 && TYPEOF(Pike_sp[2-args])==PIKE_T_STRING?
                            Pike_sp[2-args].u.string->str : NULL),
                           (TYPEOF(Pike_sp[-args]) == PIKE_T_STRING?
                            Pike_sp[-args].u.string->str : NULL),
			   (TYPEOF(Pike_sp[-args]) == PIKE_T_INT?
			    Pike_sp[-args].u.integer : -1), 0);
  INVALIDATE_CURRENT_TIME();

  fd=fd_socket(SOCKADDR_FAMILY(addr), SOCK_STREAM, 0);

  if(fd < 0)
  {
    p->my_errno=errno;
    pop_n_elems(args);
    push_int(0);
    return;
  }
#ifdef SO_REUSEPORT
  if( args > 3 && Pike_sp[3-args].u.integer )
  {
    /* FreeBSD 7.x wants this to reuse portnumbers.
     * Linux 2.6.x seems to have reserved a slot for the option, but not
     * enabled it. Survive libc's with the option on kernels without.
     *
     * The emulated Linux runtime on MS Windows 10 fails this with EINVAL.
     */
    int o=1;
    if((fd_setsockopt(fd, SOL_SOCKET, SO_REUSEPORT, (char *)&o, sizeof(int)) < 0)
#ifdef ENOPROTOOPT
       && (errno != ENOPROTOOPT)
#endif
#ifdef EINVAL
       && (errno != EINVAL)
#endif
#ifdef WSAENOPROTOOPT
       && (errno != WSAENOPROTOOPT)
#endif
       ){
      p->my_errno=errno;
      while (fd_close(fd) && errno == EINTR) {}
      errno = p->my_errno;
      pop_n_elems(args);
      push_int(0);
      return;
    }
  }
#endif
#ifndef __NT__
  {
    int o=1;
    if(fd_setsockopt(fd, SOL_SOCKET, SO_REUSEADDR, (char *)&o, sizeof(int)) < 0)
    {
      p->my_errno=errno;
      while (fd_close(fd) && errno == EINTR) {}
      errno = p->my_errno;
      pop_n_elems(args);
      push_int(0);
      return;
    }
  }
#endif

#if defined(IPV6_V6ONLY) && defined(IPPROTO_IPV6)
  if (SOCKADDR_FAMILY(addr) == AF_INET6) {
    /* Attempt to enable dual-stack (ie mapped IPv4 adresses).
     * Needed on WIN32.
     * cf http://msdn.microsoft.com/en-us/library/windows/desktop/bb513665(v=vs.85).aspx
     */
    int o = 0;
    fd_setsockopt(fd, IPPROTO_IPV6, IPV6_V6ONLY, (char *)&o, sizeof(int));
  }
#endif

  my_set_close_on_exec(fd,1);

  THREADS_ALLOW_UID();
  if( !(tmp=fd_bind(fd, (struct sockaddr *)&addr, addr_len) < 0) )
#ifdef TCP_FASTOPEN
      tmp = 256,
      setsockopt(fd,SOL_TCP, TCP_FASTOPEN, &tmp, sizeof(tmp)),
#endif
      (tmp =  fd_listen(fd, 16384) < 0);
  THREADS_DISALLOW_UID();

  if(!Pike_fp->current_object->prog)
  {
    if (fd >= 0)
      while (fd_close(fd) && errno == EINTR) {}
    Pike_error("Object destructed in Stdio.Port->bind()\n");
  }

  if(tmp)
  {
    p->my_errno=errno;
    while (fd_close(fd) && errno == EINTR) {}
    errno = p->my_errno;
    pop_n_elems(args);
    push_int(0);
    return;
  }

  change_fd_for_box (&p->box, fd);
  if(args > 1) assign_accept_cb (p, Pike_sp+1-args);
  p->my_errno=0;
  pop_n_elems(args);
  push_int(1);
}
Пример #20
0
Rboolean Rf_isSymbol(SEXP x) {
    return TYPEOF(x) == SYMSXP;
}
Пример #21
0
    void CallProxy::traverse_call( SEXP obj ){

        if( TYPEOF(obj) == LANGSXP && CAR(obj) == Rf_install("local") ) return ;

        if( TYPEOF(obj) == LANGSXP && CAR(obj) == Rf_install("global") ){
          SEXP symb = CADR(obj) ;
          if( TYPEOF(symb) != SYMSXP ) stop( "global only handles symbols" ) ;
          SEXP res = env.find(CHAR(PRINTNAME(symb))) ;
          call = res ;
          return ;
        }

        if( ! Rf_isNull(obj) ){
            SEXP head = CAR(obj) ;
            switch( TYPEOF( head ) ){
            case LANGSXP:
                if( CAR(head) == Rf_install("global") ){
                    SEXP symb = CADR(head) ;
                    if( TYPEOF(symb) != SYMSXP ) stop( "global only handles symbols" ) ;
                    SEXP res  = env.find( CHAR(PRINTNAME(symb)) ) ;

                    SETCAR(obj, res) ;
                    SET_TYPEOF(obj, LISTSXP) ;

                    break ;
                }
                if( CAR(head) == Rf_install("order_by") ) break ;
                if( CAR(head) == Rf_install("function") ) break ;
                if( CAR(head) == Rf_install("local") ) return ;
                if( CAR(head) == Rf_install("<-") ){
                    stop( "assignments are forbidden" ) ;
                }
                if( Rf_length(head) == 3 ){
                    SEXP symb = CAR(head) ;
                    if( symb == R_DollarSymbol || symb == Rf_install("@") || symb == Rf_install("::") || symb == Rf_install(":::") ){

                        // Rprintf( "CADR(obj) = " ) ;
                        // Rf_PrintValue( CADR(obj) ) ;

                        // for things like : foo( bar = bling )$bla
                        // so that `foo( bar = bling )` gets processed
                        if( TYPEOF(CADR(head)) == LANGSXP ){
                            traverse_call( CDR(head) ) ;
                        }

                        // deal with foo$bar( bla = boom )
                        if( TYPEOF(CADDR(head)) == LANGSXP ){
                            traverse_call( CDDR(head) ) ;
                        }

                        break ;
                    } else {
                      traverse_call( CDR(head) ) ;
                    }
                } else {
                    traverse_call( CDR(head) ) ;
                }

                break ;
            case LISTSXP:
                traverse_call( head ) ;
                traverse_call( CDR(head) ) ;
                break ;
            case SYMSXP:
                if( TYPEOF(obj) != LANGSXP ){
                    if( ! subsets.count(head) ){
                        if( head == R_MissingArg ) break ;
                        if( head == Rf_install(".") ) break ;

                        // in the Environment -> resolve
                        try{
                            Shield<SEXP> x( env.find( CHAR(PRINTNAME(head)) ) ) ;
                            SETCAR( obj, x );
                        } catch( ...){
                            // what happens when not found in environment
                        }

                    } else {
                        // in the data frame
                        proxies.push_back( CallElementProxy( head, obj ) );
                    }
                    break ;
                }
            }
            traverse_call( CDR(obj) ) ;
        }
    }
Пример #22
0
Rboolean Rf_isComplex(SEXP x) {
    return TYPEOF(x) == CPLXSXP;
}
Пример #23
0
SEXP do_edit(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    int   i, rc;
    ParseStatus status;
    SEXP  x, fn, envir, ti, ed, t;
    char *filename, *editcmd, *vmaxsave, *cmd;
    FILE *fp;
#ifdef Win32
    char *title;
#endif

	checkArity(op, args);

    vmaxsave = vmaxget();

    x = CAR(args); args = CDR(args);
    if (TYPEOF(x) == CLOSXP) envir = CLOENV(x);
    else envir = R_NilValue;
    PROTECT(envir);

    fn = CAR(args); args = CDR(args);
    if (!isString(fn))
	error(_("invalid argument to edit()"));

    if (LENGTH(STRING_ELT(fn, 0)) > 0) {
	filename = R_alloc(strlen(CHAR(STRING_ELT(fn, 0))), sizeof(char));
	strcpy(filename, CHAR(STRING_ELT(fn, 0)));
    }
    else filename = DefaultFileName;

    if (x != R_NilValue) {

	if((fp=R_fopen(R_ExpandFileName(filename), "w")) == NULL)
	    errorcall(call, _("unable to open file"));
	if (LENGTH(STRING_ELT(fn, 0)) == 0) EdFileUsed++;
	if (TYPEOF(x) != CLOSXP || isNull(t = getAttrib(x, R_SourceSymbol)))
	    t = deparse1(x, 0, FORSOURCING); /* deparse for sourcing, not for display */
	for (i = 0; i < LENGTH(t); i++)
	    fprintf(fp, "%s\n", CHAR(STRING_ELT(t, i)));
	fclose(fp);
    }
    ti = CAR(args); args = CDR(args);
    ed = CAR(args);
    if (!isString(ed)) errorcall(call, _("argument 'editor' type not valid"));
    cmd = CHAR(STRING_ELT(ed, 0));
    if (strlen(cmd) == 0) errorcall(call, _("argument 'editor' is not set"));
    editcmd = R_alloc(strlen(cmd) + strlen(filename) + 6, sizeof(char));
#ifdef Win32
    if (!strcmp(cmd,"internal")) {
	if (!isString(ti))
	    error(_("'title' must be a string"));
	if (LENGTH(STRING_ELT(ti, 0)) > 0) {
	    title = R_alloc(strlen(CHAR(STRING_ELT(ti, 0)))+1, sizeof(char));
	    strcpy(title, CHAR(STRING_ELT(ti, 0)));
	} else {
	    title = R_alloc(strlen(filename)+1, sizeof(char));
	    strcpy(title, filename);
	}
	Rgui_Edit(filename, title, 1);
    }
    else {
	/* Quote path if necessary */
	if(cmd[0] != '"' && Rf_strchr(cmd, ' '))
	    sprintf(editcmd, "\"%s\" \"%s\"", cmd, filename);
	else
	    sprintf(editcmd, "%s \"%s\"", cmd, filename);
	rc = runcmd(editcmd, 1, 1, "");
	if (rc == NOLAUNCH)
	    errorcall(call, _("unable to run editor '%s'"), cmd);
	if (rc != 0)
	    warningcall(call, _("editor ran but returned error status"));
    }
#else
    if (ptr_R_EditFile)
        rc = ptr_R_EditFile(filename);
    else {
        sprintf(editcmd, "%s %s", cmd, filename);
        rc = R_system(editcmd);
    }
    if (rc != 0)
	errorcall(call, _("problem with running editor %s"), cmd);
#endif

    if((fp = R_fopen(R_ExpandFileName(filename), "r")) == NULL)
	errorcall(call, _("unable to open file to read"));
    R_ParseCnt = 0;
    x = PROTECT(R_ParseFile(fp, -1, &status));
    fclose(fp);
    if (status != PARSE_OK)
	errorcall(call,
		  _("an error occurred on line %d\n use a command like\n x <- edit()\n to recover"), R_ParseError);
    R_ResetConsole();
    {   /* can't just eval(x) here */
	int j, n;
	SEXP tmp = R_NilValue;

	n = LENGTH(x);
	for (j = 0 ; j < n ; j++)
	    tmp = eval(VECTOR_ELT(x, j), R_GlobalEnv);
	x = tmp;
    }
    if (TYPEOF(x) == CLOSXP && envir != R_NilValue)
	SET_CLOENV(x, envir);
    UNPROTECT(2);
    vmaxset(vmaxsave);
    return (x);
}
Пример #24
0
Rboolean Rf_isEnvironment(SEXP x) {
    return TYPEOF(x) == ENVSXP;
}
Пример #25
0
SEXP _do_subset_xts (SEXP x, SEXP sr, SEXP sc, SEXP drop) {
  SEXP result;
  int i, j, nr, nc, nrs, ncs;
  int P=0;

  SEXP Dim = getAttrib(x, R_DimSymbol);
  nrs = nrows(x);ncs = ncols(x);
  nr = length(sr); nc = length(sc);

  SEXP oindex, nindex;
  oindex = getAttrib(x, install("index"));
  PROTECT(nindex = allocVector(TYPEOF(oindex), nr)); P++;
  PROTECT(result = allocVector(TYPEOF(x), nr*nc)); P++;
  j = 0;

  double *real_nindex=NULL, *real_oindex, *real_result=NULL, *real_x=NULL; 
  int *int_nindex=NULL, *int_oindex, *int_result=NULL, *int_x=NULL; 
  int *int_sr=NULL, *int_sc=NULL;
  int_sr = INTEGER(sr);
  int_sc = INTEGER(sc);

  copyAttributes(x, result);

  if(TYPEOF(x)==LGLSXP) {
    int_x = LOGICAL(x); 
    int_result = LOGICAL(result); 
    if(TYPEOF(nindex)==INTSXP) {
      int_nindex = INTEGER(nindex);
      int_oindex = INTEGER(oindex);
      for(i=0; i<nr; i++) {
        if(int_sr[i] == NA_INTEGER)
          error("'i' contains NA");
        if(int_sr[i] > nrs || int_sc[j] > ncs)
          error("'i' or 'j' out of range");
        int_nindex[i] = int_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER)
          int_result[i+j*nr] = NA_INTEGER;
        else
          int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    } else
    if(TYPEOF(nindex)==REALSXP) {
      real_nindex = REAL(nindex);
      real_oindex = REAL(oindex);
      for(i=0; i<nr; i++) {
        real_nindex[i] = real_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER)
          int_result[i+j*nr] = NA_INTEGER;
        else
          int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    }
    copyAttributes(oindex, nindex);
    setAttrib(result, install("index"), nindex);
    for(j=1; j<nc; j++) {
      for(i=0; i<nr; i++) {
        if(int_sc[j] == NA_INTEGER)
          int_result[i+j*nr] = NA_INTEGER;
        else
          int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    }
  } else
  /* branch into INTSXP and REALSXP, as these are most
     common/important types for time series data 
  */
  if(TYPEOF(x)==INTSXP) {
    int_x = INTEGER(x); 
    int_result = INTEGER(result); 
    if(TYPEOF(nindex)==INTSXP) {
      int_nindex = INTEGER(nindex);
      int_oindex = INTEGER(oindex);
      for(i=0; i<nr; i++) {
        if(int_sr[i] == NA_INTEGER)
          error("'i' contains NA");
        if(int_sr[i] > nrs || int_sc[j] > ncs)
          error("'i' or 'j' out of range");
        int_nindex[i] = int_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER)
          int_result[i+j*nr] = NA_INTEGER;
        else
          int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    } else
    if(TYPEOF(nindex)==REALSXP) {
      real_nindex = REAL(nindex);
      real_oindex = REAL(oindex);
      for(i=0; i<nr; i++) {
        if(int_sr[i] == NA_INTEGER)
          error("'i' contains NA");
        if(int_sr[i] > nrs || int_sc[j] > ncs)
          error("'i' or 'j' out of range");
        real_nindex[i] = real_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER)
          int_result[i+j*nr] = NA_INTEGER;
        else
          int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    }
    copyAttributes(oindex, nindex);
    setAttrib(result, install("index"), nindex);

    /* loop through remaining columns */
    for(j=1; j<nc; j++) {
      for(i=0; i<nr; i++) {
        if(int_sc[j] == NA_INTEGER)
          int_result[i+j*nr] = NA_INTEGER;
        else
          int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    }
  } else
  if(TYPEOF(x)==REALSXP) {
    real_x = REAL(x);
    real_result = REAL(result);
    if(TYPEOF(nindex)==INTSXP) {
      int_nindex = INTEGER(nindex);
      int_oindex = INTEGER(oindex);
      for(i=0; i<nr; i++) {
        if(int_sr[i] == NA_INTEGER)
          error("'i' contains NA");
        if(int_sr[i] > nrs || int_sc[j] > ncs)
          error("'i' or 'j' out of range");
        int_nindex[i] = int_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER)
          real_result[i+j*nr] = NA_REAL;
        else
          real_result[i+j*nr] = real_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    } else
    if(TYPEOF(nindex)==REALSXP) {
      real_nindex = REAL(nindex);
      real_oindex = REAL(oindex);
      for(i=0; i<nr; i++) {
        if(int_sr[i] == NA_INTEGER)
          error("'i' contains NA");
        if(int_sr[i] > nrs || int_sc[j] > ncs)
          error("'i' or 'j' out of range");
        real_nindex[i] = real_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER)
          real_result[i+j*nr] = NA_REAL;
        else
          real_result[i+j*nr] = real_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    }
    copyAttributes(oindex, nindex);
    setAttrib(result, install("index"), nindex);

    for(j=1; j<nc; j++) {
      for(i=0; i<nr; i++) {
        if(int_sc[j] == NA_INTEGER)
          real_result[i+j*nr] = NA_REAL;
        else
          real_result[i+j*nr] = real_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    }
  } else
  if(TYPEOF(x)==CPLXSXP) {
    /*
    real_x = REAL(x);
    real_result = REAL(result);
    */
    if(TYPEOF(nindex)==INTSXP) {
      int_nindex = INTEGER(nindex);
      int_oindex = INTEGER(oindex);
      for(i=0; i<nr; i++) {
        if(int_sr[i] == NA_INTEGER)
          error("'i' contains NA");
        if(int_sr[i] > nrs || int_sc[j] > ncs)
          error("'i' or 'j' out of range");
        int_nindex[i] = int_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER) {
          COMPLEX(result)[i+j*nr].r = NA_REAL;
          COMPLEX(result)[i+j*nr].i = NA_REAL;
        } else
          COMPLEX(result)[i+j*nr] = COMPLEX(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    } else
    if(TYPEOF(nindex)==REALSXP) {
      real_nindex = REAL(nindex);
      real_oindex = REAL(oindex);
      for(i=0; i<nr; i++) {
        if(int_sr[i] == NA_INTEGER)
          error("'i' contains NA");
        if(int_sr[i] > nrs || int_sc[j] > ncs)
          error("'i' or 'j' out of range");
        real_nindex[i] = real_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER) {
          COMPLEX(result)[i+j*nr].r = NA_REAL;
          COMPLEX(result)[i+j*nr].i = NA_REAL;
        } else
          COMPLEX(result)[i+j*nr] = COMPLEX(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    }
    copyAttributes(oindex, nindex);
    setAttrib(result, install("index"), nindex);

    for(j=1; j<nc; j++) {
      for(i=0; i<nr; i++) {
        if(int_sc[j] == NA_INTEGER) {
          COMPLEX(result)[i+j*nr].r = NA_REAL;
          COMPLEX(result)[i+j*nr].i = NA_REAL;
        } else
          COMPLEX(result)[i+j*nr] = COMPLEX(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    }
  } else
  if(TYPEOF(x)==STRSXP) {
    if(TYPEOF(nindex)==INTSXP) {
      int_nindex = INTEGER(nindex);
      int_oindex = INTEGER(oindex);
      for(i=0; i<nr; i++) {
        if(int_sr[i] == NA_INTEGER)
          error("'i' contains NA");
        if(int_sr[i] > nrs || int_sc[j] > ncs)
          error("'i' or 'j' out of range");
        int_nindex[i] = int_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER)
          SET_STRING_ELT(result, i+j*nr, NA_STRING);
        else
          SET_STRING_ELT(result, i+j*nr, STRING_ELT(x, int_sr[i]-1 + ((int_sc[j]-1) * nrs)));
      }
    } else
    if(TYPEOF(nindex)==REALSXP) {
      real_nindex = REAL(nindex);
      real_oindex = REAL(oindex);
      for(i=0; i<nr; i++) {
        if(int_sr[i] == NA_INTEGER)
          error("'i' contains NA");
        if(int_sr[i] > nrs || int_sc[j] > ncs)
          error("'i' or 'j' out of range");
        real_nindex[i] = real_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER)
          SET_STRING_ELT(result, i+j*nr, NA_STRING);
        else
          SET_STRING_ELT(result, i+j*nr, STRING_ELT(x, int_sr[i]-1 + ((int_sc[j]-1) * nrs)));
      }
    }
    copyAttributes(oindex, nindex);
    setAttrib(result, install("index"), nindex);

    for(j=1; j<nc; j++) {
      for(i=0; i<nr; i++) {
        if(int_sc[j] == NA_INTEGER)
          SET_STRING_ELT(result, i+j*nr, NA_STRING);
        else
          SET_STRING_ELT(result, i+j*nr, STRING_ELT(x, int_sr[i]-1 + ((int_sc[j]-1) * nrs)));
      }
    }
  } else
  if(TYPEOF(x)==RAWSXP) {
    /*
    real_x = REAL(x);
    real_result = REAL(result);
    */
    if(TYPEOF(nindex)==INTSXP) {
      int_nindex = INTEGER(nindex);
      int_oindex = INTEGER(oindex);
      for(i=0; i<nr; i++) {
        if(int_sr[i] == NA_INTEGER)
          error("'i' contains NA");
        if(int_sr[i] > nrs || int_sc[j] > ncs)
          error("'i' or 'j' out of range");
        int_nindex[i] = int_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER)
          RAW(result)[i+j*nr] = 0;
        else
          RAW(result)[i+j*nr] = RAW(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    } else
    if(TYPEOF(nindex)==REALSXP) {
      real_nindex = REAL(nindex);
      real_oindex = REAL(oindex);
      for(i=0; i<nr; i++) {
        if(int_sr[i] == NA_INTEGER)
          error("'i' contains NA");
        if(int_sr[i] > nrs || int_sc[j] > ncs)
          error("'i' or 'j' out of range");
        real_nindex[i] = real_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER)
          RAW(result)[i+j*nr] = 0;
        else
          RAW(result)[i+j*nr] = RAW(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    }
    copyAttributes(oindex, nindex);
    setAttrib(result, install("index"), nindex);

    for(j=1; j<nc; j++) {
      for(i=0; i<nr; i++) {
        if(int_sc[j] == NA_INTEGER)
          RAW(result)[i+j*nr] = 0;
        else
          RAW(result)[i+j*nr] = RAW(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    }
  }


  if(!isNull(Dim) && nr >= 0 && nc >= 0) {
  SEXP dim;
  PROTECT(dim = allocVector(INTSXP,2));P++;
  INTEGER(dim)[0] = nr;
  INTEGER(dim)[1] = nc;
  setAttrib(result, R_DimSymbol, dim);

   if (nr >= 0 && nc >= 0) {
    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,
            ExtractSubset(VECTOR_ELT(dimnames, 0),
                  allocVector(STRSXP, nr), sr));
          SET_VECTOR_ELT(newdimnames, 1,
            ExtractSubset(VECTOR_ELT(dimnames, 1),
                  allocVector(STRSXP, nc), sc));
        }
        else {
          SET_VECTOR_ELT(newdimnames, 0,
            ExtractSubset(CAR(dimnames),
                  allocVector(STRSXP, nr), sr));
          SET_VECTOR_ELT(newdimnames, 1,
            ExtractSubset(CADR(dimnames),
                  allocVector(STRSXP, nc), sc));
        }
        setAttrib(newdimnames, R_NamesSymbol, dimnamesnames);
        setAttrib(result, R_DimNamesSymbol, newdimnames);
        UNPROTECT(1);
    }
    }

  }
  setAttrib(result, R_ClassSymbol, getAttrib(x, R_ClassSymbol));
  if(nc == 1 && LOGICAL(drop)[0])
    setAttrib(result, R_DimSymbol, R_NilValue);


  UNPROTECT(P);
  return result;
}
Пример #26
0
Rboolean Rf_isExpression(SEXP x) {
    return TYPEOF(x) == EXPRSXP;
}
Пример #27
0
SEXP extract_col (SEXP x, SEXP j, SEXP drop, SEXP first_, SEXP last_) {
  SEXP result, index, new_index;
  int nrs, nrsx, i, ii, jj, first, last;

  nrsx = nrows(x);

  first = asInteger(first_)-1;
  last = asInteger(last_)-1;

  /* nrs = offset_end - offset_start - 1; */
  nrs = last - first + 1;
  

  PROTECT(result = allocVector(TYPEOF(x), nrs * length(j)));

  switch(TYPEOF(x)) {
    case REALSXP:
      for(i=0; i<length(j); i++) {
/*
Rprintf("j + i*nrs + first=%i\n", (int)(INTEGER(j)[i]-1 + i*nrs + first));
Rprintf("i=%i, j=%i, nrs=%i, first=%i\n", i, INTEGER(j)[i]-1, nrs, first);
*/
        if(INTEGER(j)[i] == NA_INTEGER) {
          for(ii=0; ii < nrs; ii++) {
            REAL(result)[(i*nrs) + ii] = NA_REAL;
          }
        } else {
          memcpy(&(REAL(result)[i*nrs]),
                 &(REAL(x)[(INTEGER(j)[i]-1)*nrsx + first]),
                 nrs*sizeof(double));
        }
      }
      break;
    case INTSXP:
      for(i=0; i<length(j); i++) {
        if(INTEGER(j)[i] == NA_INTEGER) {
          for(ii=0; ii < nrs; ii++) {
            INTEGER(result)[(i*nrs) + ii] = NA_INTEGER;
          }
        } else {
          memcpy(&(INTEGER(result)[i*nrs]),
                 &(INTEGER(x)[(INTEGER(j)[i]-1)*nrsx + first]),
                 nrs*sizeof(int));
        }
      }
      break;
    case LGLSXP:
      for(i=0; i<length(j); i++) {
        if(INTEGER(j)[i] == NA_INTEGER) {
          for(ii=0; ii < nrs; ii++) {
            LOGICAL(result)[(i*nrs) + ii] = NA_LOGICAL;
          }
        } else {
          memcpy(&(LOGICAL(result)[i*nrs]),
                 &(LOGICAL(x)[(INTEGER(j)[i]-1)*nrsx + first]),
                 nrs*sizeof(int));
        }
      }
      break;
    case CPLXSXP:
      for(i=0; i<length(j); i++) {
        if(INTEGER(j)[i] == NA_INTEGER) {
          for(ii=0; ii < nrs; ii++) {
            COMPLEX(result)[(i*nrs) + ii].r = NA_REAL;
            COMPLEX(result)[(i*nrs) + ii].i = NA_REAL;
          }
        } else {
          memcpy(&(COMPLEX(result)[i*nrs]),
                 &(COMPLEX(x)[(INTEGER(j)[i]-1)*nrsx + first]),
                 nrs*sizeof(Rcomplex));
        }
      }
      break;
    case RAWSXP:
      for(i=0; i<length(j); i++) {
        if(INTEGER(j)[i] == NA_INTEGER) {
          for(ii=0; ii < nrs; ii++) {
            RAW(result)[(i*nrs) + ii] = 0;
          }
        } else {
          memcpy(&(RAW(result)[i*nrs]),
                 &(RAW(x)[(INTEGER(j)[i]-1)*nrsx + first]),
                 nrs*sizeof(Rbyte));
        }
      }
      break;
    case STRSXP:
      for(jj=0; jj<length(j); jj++) {
        if(INTEGER(j)[jj] == NA_INTEGER) {
          for(i=0; i< nrs; i++)
            SET_STRING_ELT(result, i+jj*nrs, NA_STRING);
        } else {
          for(i=0; i< nrs; i++)
            SET_STRING_ELT(result, i+jj*nrs, STRING_ELT(x, i+(INTEGER(j)[jj]-1)*nrsx+first));
        }
      }
      break;
    default:
      error("unsupported type");
  }

  if(nrs != nrows(x)) {
    copyAttributes(x, result);
    /* subset index */
    index = getAttrib(x, install("index"));
    PROTECT(new_index = allocVector(TYPEOF(index), nrs)); 
    if(TYPEOF(index) == REALSXP) {
      memcpy(REAL(new_index), &(REAL(index)[first]), nrs*sizeof(double)); 
    } else { /* INTSXP */
      memcpy(INTEGER(new_index), &(INTEGER(index)[first]), nrs*sizeof(int)); 
    }
    copyMostAttrib(index, new_index);
    setAttrib(result, install("index"), new_index);
    UNPROTECT(1);
  } else {
    copyMostAttrib(x, result); /* need an xts/zoo equal that skips 'index' */
  }

  if(!asLogical(drop)) { /* keep dimension and dimnames */
    SEXP dim;
    PROTECT(dim = allocVector(INTSXP, 2));
    INTEGER(dim)[0] = nrs;
    INTEGER(dim)[1] = length(j);
    setAttrib(result, R_DimSymbol, dim);
    UNPROTECT(1);

    SEXP dimnames, currentnames, newnames;
    PROTECT(dimnames = allocVector(VECSXP, 2));
    PROTECT(newnames = allocVector(STRSXP, length(j)));
    currentnames = getAttrib(x, R_DimNamesSymbol);

    if(!isNull(currentnames)) {
      SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(currentnames,0));
      if(!isNull(VECTOR_ELT(currentnames,1))) {
        /* if colnames isn't NULL set */
        for(i=0; i<length(j); i++) {
          SET_STRING_ELT(newnames, i, STRING_ELT(VECTOR_ELT(currentnames,1), INTEGER(j)[i]-1));
        }
        SET_VECTOR_ELT(dimnames, 1, newnames);
      } else {
        /* else set to NULL */
        SET_VECTOR_ELT(dimnames, 1, R_NilValue);
      }
      setAttrib(result, R_DimNamesSymbol, dimnames);
    }
    UNPROTECT(2);
  }

  UNPROTECT(1);
  return result;
}
Пример #28
0
Rboolean Rf_isLogical(SEXP x) {
    return TYPEOF(x) == LGLSXP;
}
Пример #29
0
SEXP attribute_hidden do_relop_dflt(SEXP call, SEXP op, SEXP x, SEXP y)
{
    SEXP klass = R_NilValue, dims, tsp=R_NilValue, xnames, ynames;
    int nx, ny, xarray, yarray, xts, yts;
    Rboolean mismatch = FALSE, iS;
    PROTECT_INDEX xpi, ypi;

    PROTECT_WITH_INDEX(x, &xpi);
    PROTECT_WITH_INDEX(y, &ypi);
    nx = length(x);
    ny = length(y);

    /* pre-test to handle the most common case quickly.
       Used to skip warning too ....
     */
    if (ATTRIB(x) == R_NilValue && ATTRIB(y) == R_NilValue &&
	TYPEOF(x) == REALSXP && TYPEOF(y) == REALSXP &&
	LENGTH(x) > 0 && LENGTH(y) > 0) {
	SEXP ans = real_relop((RELOP_TYPE) PRIMVAL(op), x, y);
	if (nx > 0 && ny > 0)
	    mismatch = ((nx > ny) ? nx % ny : ny % nx) != 0;
	if (mismatch) {
	    PROTECT(ans);
	    warningcall(call, _("longer object length is not a multiple of shorter object length"));
	    UNPROTECT(1);
	}
	UNPROTECT(2);
	return ans;
    }

    /* That symbols and calls were allowed was undocumented prior to
       R 2.5.0.  We deparse them as deparse() would, minus attributes */
    if ((iS = isSymbol(x)) || TYPEOF(x) == LANGSXP) {
	SEXP tmp = allocVector(STRSXP, 1);
	PROTECT(tmp);
	SET_STRING_ELT(tmp, 0, (iS) ? PRINTNAME(x) :
		       STRING_ELT(deparse1(x, 0, DEFAULTDEPARSE), 0));
	REPROTECT(x = tmp, xpi);
	UNPROTECT(1);
    }
    if ((iS = isSymbol(y)) || TYPEOF(y) == LANGSXP) {
	SEXP tmp = allocVector(STRSXP, 1);
	PROTECT(tmp);
	SET_STRING_ELT(tmp, 0, (iS) ? PRINTNAME(y) :
		       STRING_ELT(deparse1(y, 0, DEFAULTDEPARSE), 0));
	REPROTECT(y = tmp, ypi);
	UNPROTECT(1);
    }

    if (!isVector(x) || !isVector(y)) {
	if (isNull(x) || isNull(y)) {
	    UNPROTECT(2);
	    return allocVector(LGLSXP,0);
	}
	errorcall(call,
		  _("comparison (%d) is possible only for atomic and list types"),
		  PRIMVAL(op));
    }

    if (TYPEOF(x) == EXPRSXP || TYPEOF(y) == EXPRSXP)
	errorcall(call, _("comparison is not allowed for expressions"));

    /* ELSE :  x and y are both atomic or list */

    if (LENGTH(x) <= 0 || LENGTH(y) <= 0) {
	UNPROTECT(2);
	return allocVector(LGLSXP,0);
    }

    mismatch = FALSE;
    xarray = isArray(x);
    yarray = isArray(y);
    xts = isTs(x);
    yts = isTs(y);
    if (nx > 0 && ny > 0)
	mismatch = ((nx > ny) ? nx % ny : ny % nx) != 0;

    if (xarray || yarray) {
	if (xarray && yarray) {
	    if (!conformable(x, y))
		errorcall(call, _("non-conformable arrays"));
	    PROTECT(dims = getAttrib(x, R_DimSymbol));
	}
	else if (xarray) {
	    PROTECT(dims = getAttrib(x, R_DimSymbol));
	}
	else /*(yarray)*/ {
	    PROTECT(dims = getAttrib(y, R_DimSymbol));
	}
	PROTECT(xnames = getAttrib(x, R_DimNamesSymbol));
	PROTECT(ynames = getAttrib(y, R_DimNamesSymbol));
    }
    else {
	PROTECT(dims = R_NilValue);
	PROTECT(xnames = getAttrib(x, R_NamesSymbol));
	PROTECT(ynames = getAttrib(y, R_NamesSymbol));
    }
    if (xts || yts) {
	if (xts && yts) {
	    if (!tsConform(x, y))
		errorcall(call, _("non-conformable time series"));
	    PROTECT(tsp = getAttrib(x, R_TspSymbol));
	    PROTECT(klass = getAttrib(x, R_ClassSymbol));
	}
	else if (xts) {
	    if (length(x) < length(y))
		ErrorMessage(call, ERROR_TSVEC_MISMATCH);
	    PROTECT(tsp = getAttrib(x, R_TspSymbol));
	    PROTECT(klass = getAttrib(x, R_ClassSymbol));
	}
	else /*(yts)*/ {
	    if (length(y) < length(x))
		ErrorMessage(call, ERROR_TSVEC_MISMATCH);
	    PROTECT(tsp = getAttrib(y, R_TspSymbol));
	    PROTECT(klass = getAttrib(y, R_ClassSymbol));
	}
    }
    if (mismatch)
	warningcall(call, _("longer object length is not a multiple of shorter object length"));

    if (isString(x) || isString(y)) {
	REPROTECT(x = coerceVector(x, STRSXP), xpi);
	REPROTECT(y = coerceVector(y, STRSXP), ypi);
	x = string_relop((RELOP_TYPE) PRIMVAL(op), x, y);
    }
    else if (isComplex(x) || isComplex(y)) {
	REPROTECT(x = coerceVector(x, CPLXSXP), xpi);
	REPROTECT(y = coerceVector(y, CPLXSXP), ypi);
	x = complex_relop((RELOP_TYPE) PRIMVAL(op), x, y, call);
    }
    else if (isReal(x) || isReal(y)) {
	REPROTECT(x = coerceVector(x, REALSXP), xpi);
	REPROTECT(y = coerceVector(y, REALSXP), ypi);
	x = real_relop((RELOP_TYPE) PRIMVAL(op), x, y);
    }
    else if (isInteger(x) || isInteger(y)) {
	REPROTECT(x = coerceVector(x, INTSXP), xpi);
	REPROTECT(y = coerceVector(y, INTSXP), ypi);
	x = integer_relop((RELOP_TYPE) PRIMVAL(op), x, y);
    }
    else if (isLogical(x) || isLogical(y)) {
	REPROTECT(x = coerceVector(x, LGLSXP), xpi);
	REPROTECT(y = coerceVector(y, LGLSXP), ypi);
	x = integer_relop((RELOP_TYPE) PRIMVAL(op), x, y);
    }
    else if (TYPEOF(x) == RAWSXP || TYPEOF(y) == RAWSXP) {
	REPROTECT(x = coerceVector(x, RAWSXP), xpi);
	REPROTECT(y = coerceVector(y, RAWSXP), ypi);
	x = raw_relop((RELOP_TYPE) PRIMVAL(op), x, y);
    } else errorcall(call, _("comparison of these types is not implemented"));


    PROTECT(x);
    if (dims != R_NilValue) {
	setAttrib(x, R_DimSymbol, dims);
	if (xnames != R_NilValue)
	    setAttrib(x, R_DimNamesSymbol, xnames);
	else if (ynames != R_NilValue)
	    setAttrib(x, R_DimNamesSymbol, ynames);
    }
    else {
	if (length(x) == length(xnames))
	    setAttrib(x, R_NamesSymbol, xnames);
	else if (length(x) == length(ynames))
	    setAttrib(x, R_NamesSymbol, ynames);
    }
    if (xts || yts) {
	setAttrib(x, R_TspSymbol, tsp);
	setAttrib(x, R_ClassSymbol, klass);
	UNPROTECT(2);
    }

    UNPROTECT(6);
    return x;
}
Пример #30
0
SEXP zoo_lag (SEXP x, SEXP _k, SEXP _pad)
{
#ifdef ZOO_DEBUG
Rprintf("zoo_lag\n");
#endif
  SEXP result;
  int i,j;
  double *result_real=NULL;
  int    *result_int=NULL;

  int k=INTEGER(_k)[0] * -1; /* -1 is zoo convention */
  int k_positive = (k > 0) ? 1 : 0;
  int nr = nrows(x);
  int nc = ncols(x);
  int P=0;
  int PAD = INTEGER(coerceVector(_pad,INTSXP))[0];

  if(k > nr)
    error("abs(k) must be less than nrow(x)");

  if(k < 0 && -1*k > nr)
    error("abs(k) must be less than nrow(x)");

  PROTECT(result = allocVector(TYPEOF(x), 
          length(x) - (PAD ? 0 : abs(k)*nc))); P++;
  int nrr = (int)(length(result)/nc);

  if(k_positive) {
  switch(TYPEOF(x)) {
    case REALSXP:
      result_real = REAL(result);
      for(j = 0; j < nc; j++) {
        if(PAD) {
          for(i = 0; i < k; i++)
            result_real[i+(j*nrr)] = NA_REAL;
          memcpy(&REAL(result)[k+(j*nrr)], 
                 &REAL(x)[(j*nrr)], 
                 (nrr-k) * sizeof(double)); 
        } else {
        memcpy(&REAL(result)[(j*nrr)], 
               &REAL(x)[(j*nr)], /* original data need the original 'nr' offset */
               nrr * sizeof(double)); 
        }
      }
      break;
    case INTSXP:
      result_int = INTEGER(result);
      for(j = 0; j < nc; j++) {
        if(PAD) {
          for(i = 0; i < k; i++)
            result_int[i+(j*nrr)] = NA_INTEGER;
          memcpy(&INTEGER(result)[k+(j*nrr)],
                 &INTEGER(x)[(j*nrr)],
                 (nrr-k) * sizeof(int));
        } else {
          memcpy(&INTEGER(result)[(j*nrr)],
                 &INTEGER(x)[(j*nr)],
                 nrr * sizeof(int));
        }
      }
      break;
    case LGLSXP:
      result_int = LOGICAL(result);
      for(j = 0; j < nc; j++) {
        if(PAD) {
          for(i = 0; i < k; i++)
            result_int[i+(j*nrr)] = NA_INTEGER;
          memcpy(&LOGICAL(result)[k+(j*nrr)],
                 &LOGICAL(x)[(j*nrr)],
                 (nrr-k) * sizeof(int));
        } else {
          memcpy(&LOGICAL(result)[(j*nrr)],
                 &LOGICAL(x)[(j*nr)],
                 nrr * sizeof(int));
        }
      }
      break;
    case CPLXSXP:
      for(j = 0; j < nc; j++) {
        if(PAD) {
          for(i = 0; i < k; i++) {
            COMPLEX(result)[i+(j*nrr)].r = NA_REAL;
            COMPLEX(result)[i+(j*nrr)].i = NA_REAL;
          }
          memcpy(&COMPLEX(result)[k+(j*nrr)],
                 &COMPLEX(x)[(j*nrr)],
                 (nrr-k) * sizeof(Rcomplex));
        } else {
          memcpy(&COMPLEX(result)[(j*nrr)],
                 &COMPLEX(x)[(j*nr)],
                 nrr * sizeof(Rcomplex));
        }
      }
      break;
    case RAWSXP:
      for(j = 0; j < nc; j++) {
        if(PAD) {
          for(i = 0; i < k; i++)
            RAW(result)[i+(j*nrr)] = (Rbyte) 0;
          memcpy(&RAW(result)[k+(j*nrr)],
                 &RAW(x)[(j*nrr)],
                 (nrr-k) * sizeof(Rbyte));
        } else {
          memcpy(&RAW(result)[(j*nrr)],
                 &RAW(x)[(j*nr)],
                 nrr * sizeof(Rbyte));
        }
      }
      break;
    case STRSXP:
      for(j = 0; j < nc; j++) {
        if(PAD) {
          for(i = 0; i < k; i++)
            SET_STRING_ELT(result, i+(j*nrr), NA_STRING);
          for(i = 0; i < nrr-k; i++) 
            SET_STRING_ELT(result, k+i+j*nrr, STRING_ELT(x, i+j*nrr));
        } else {
          for(i = 0; i < nrr; i++) 
            SET_STRING_ELT(result, i+j*nrr, STRING_ELT(x, i+j*nr));
        }
      }
      break;
    default:
      error("unsupported type");
      break;
  }
  } else
  if(!k_positive) {
  k = abs(k);
  switch(TYPEOF(x)) {
    case REALSXP:
      result_real = REAL(result);
      for(j =0; j < nc; j++) {
        if(PAD) {
          for(i = nr-k; i < nr; i++)
            result_real[i+(j*nrr)] = NA_REAL;
          memcpy(&REAL(result)[(j*nrr)], 
                 &REAL(x)[k+(j*nrr)], 
                 (nrr-k) * sizeof(double));
        } else {
        memcpy(&REAL(result)[(j*nrr)],
               &REAL(x)[k+(j*nr)],
               nrr * sizeof(double));
        }
      }
      break;
    case INTSXP:
      result_int = INTEGER(result);
      for(j = 0; j < nc; j++) {
        if(PAD) {
          for(i = nr-k; i < nr; i++)
            result_int[i+(j*nrr)] = NA_INTEGER;
          memcpy(&INTEGER(result)[(j*nrr)],
                 &INTEGER(x)[k+(j*nrr)],
                 (nrr-k) * sizeof(int));
        } else {
          memcpy(&INTEGER(result)[(j*nrr)],
                 &INTEGER(x)[k+(j*nr)],
                 nrr * sizeof(int));
        }
      }
      break;
    case LGLSXP:
      result_int = LOGICAL(result);
      for(j = 0; j < nc; j++) {
        if(PAD) {
          for(i = nr-k; i < nr; i++)
            result_int[i+(j*nrr)] = NA_INTEGER;
          memcpy(&LOGICAL(result)[(j*nrr)],
                 &LOGICAL(x)[k+(j*nrr)],
                 (nrr-k) * sizeof(int));
        } else {
          memcpy(&LOGICAL(result)[(j*nrr)],
                 &LOGICAL(x)[k+(j*nr)],
                 nrr * sizeof(int));
        }
      }
      break;
    case CPLXSXP:
      for(j = 0; j < nc; j++) {
        if(PAD) {
          for(i = nr-k; i < nr; i++) {
            COMPLEX(result)[i+(j*nrr)].r = NA_REAL;
            COMPLEX(result)[i+(j*nrr)].i = NA_REAL;
          }
          memcpy(&COMPLEX(result)[(j*nrr)],
                 &COMPLEX(x)[k+(j*nrr)],
                 (nrr-k) * sizeof(Rcomplex));
        } else {
          memcpy(&COMPLEX(result)[(j*nrr)],
                 &COMPLEX(x)[k+(j*nr)],
                 nrr * sizeof(Rcomplex));
        }
      }
      break;
    case RAWSXP:
      for(j = 0; j < nc; j++) {
        if(PAD) {
          for(i = nr-k; i < nr; i++)
            RAW(result)[i+(j*nrr)] = (Rbyte) 0;
          memcpy(&RAW(result)[(j*nrr)],
                 &RAW(x)[k+(j*nrr)],
                 (nrr-k) * sizeof(Rbyte));
        } else {
          memcpy(&RAW(result)[(j*nrr)],
                 &RAW(x)[k+(j*nr)],
                 nrr * sizeof(Rbyte));
        }
      }
      break;
    case STRSXP:
      for(j = 0; j < nc; j++) {
        if(PAD) {
          for(i = nr-k; i < nr; i++)
            SET_STRING_ELT(result, i+(j*nrr), NA_STRING);
          for(i = 0; i < nrr-k; i++)
            SET_STRING_ELT(result, i+(j*nrr), STRING_ELT(x, k+i+(j*nrr)));
        } else {
          for(i = 0; i < nr-k; i++)
            SET_STRING_ELT(result, i+(j*nrr), STRING_ELT(x, k+i+(j*nr)));
        }
      }
      break;
    default:
      error("unsupported type");
      break;
  }
  }

  copyMostAttrib(x,result);
  if(!PAD) {
    // likely unneeded as copyMostAttrib will cover
  //  setAttrib(result, install("index"), getAttrib(x, install("index")));
  //} else {
    SEXP index, newindex;
    PROTECT(index = getAttrib(x, install("index"))); P++;
    if(IS_S4_OBJECT(index)) {
      /* should make this
         1) generic for any S4 object if possible
         2) test for timeDate as this is important
      */
      if(STRING_ELT(getAttrib(index, R_ClassSymbol),0)!=mkChar("timeDate"))
        error("'S4' objects must be of class 'timeDate'");
      index = GET_SLOT(index, install("Data"));
    }
    PROTECT(newindex = allocVector(TYPEOF(index), nrr)); P++;
    switch(TYPEOF(index)) {
      case REALSXP:
        if(k_positive) {
          memcpy(REAL(newindex), &REAL(index)[k], nrr * sizeof(double));
        } else {
          memcpy(REAL(newindex), REAL(index), nrr * sizeof(double));
        }
        break;
      case INTSXP:
        if(k_positive) {
        memcpy(INTEGER(newindex), &INTEGER(index)[k], nrr * sizeof(int));
        } else {
        memcpy(INTEGER(newindex), INTEGER(index), nrr * sizeof(int));
        }
        break;
      default:
        break;
    }
    if(IS_S4_OBJECT(getAttrib(x, install("index")))) {
      /* need to assure that this is timeDate */
      SEXP tmp = PROTECT(getAttrib(x, install("index"))); P++;
      SEXP timeDate = PROTECT(NEW_OBJECT(MAKE_CLASS("timeDate"))); P++;
      copyMostAttrib(index,newindex);
      SET_SLOT(timeDate,install("Data"),newindex);
      SET_SLOT(timeDate,install("format"),
               GET_SLOT(tmp, install("format")));
      SET_SLOT(timeDate,install("FinCenter"),
               GET_SLOT(tmp, install("FinCenter")));
      setAttrib(result, install("index"), timeDate);
    } else {
      copyMostAttrib(index, newindex);
      setAttrib(result, install("index"), newindex);
    }
  } 

  /* reset dims */
  if(!isNull(getAttrib(x, R_DimSymbol))) {
    SEXP dims;
    PROTECT(dims = allocVector(INTSXP, 2)); P++;
    INTEGER(dims)[0] = nrr;
    INTEGER(dims)[1] = nc;
    setAttrib(result, R_DimSymbol, dims); 
    setAttrib(result, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol)); 
  }

  UNPROTECT(P);
  return result;
}