C++ TYPEOF函数代码示例

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);
}

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;
//.........这里部分代码省略.........

/* 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;
//.........这里部分代码省略.........

  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];
		  }
//.........这里部分代码省略.........

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

  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:
//.........这里部分代码省略.........

 void CallProxy::set_call( SEXP call_ ){
     proxies.clear() ;
     call = call_ ;
     if( TYPEOF(call) == LANGSXP ) traverse_call(call) ;
 }

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

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);
}

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

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);
}

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;
//.........这里部分代码省略.........

//.........这里部分代码省略.........
  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];
  }

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

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);
}