C++ Rf_allocVector函数代码示例

 static SEXP make_condition(const std::string& ex_msg, SEXP call, SEXP cppstack, SEXP classes){
     Scoped<SEXP> res     = Rf_allocVector( VECSXP, 3 ) ;
     Scoped<SEXP> message = Rf_mkString( ex_msg.c_str() ) ;
     RCPP_SET_VECTOR_ELT( res, 0, message ) ;
     RCPP_SET_VECTOR_ELT( res, 1, call ) ;
     RCPP_SET_VECTOR_ELT( res, 2, cppstack ) ;
     Scoped<SEXP> names = Rf_allocVector( STRSXP, 3 ) ;
     SET_STRING_ELT( names, 0, Rf_mkChar( "message" ) ) ;
     SET_STRING_ELT( names, 1, Rf_mkChar( "call" ) ) ;
     SET_STRING_ELT( names, 2, Rf_mkChar( "cppstack" ) ) ;
     Rf_setAttrib( res, R_NamesSymbol, names ) ;
     Rf_setAttrib( res, R_ClassSymbol, classes ) ;
     return res ;
 }

static SEXP
rpf_dTheta_wrapper(SEXP r_spec, SEXP r_param, SEXP r_where, SEXP r_dir)
{
  if (Rf_length(r_spec) < RPF_ISpecCount)
    Rf_error("Item spec must be of length %d, not %d", RPF_ISpecCount, Rf_length(r_spec));

  double *spec = REAL(r_spec);

  int id = spec[RPF_ISpecID];
  if (id < 0 || id >= Glibrpf_numModels)
    Rf_error("Item model %d out of range", id);

  int numSpec = (*Glibrpf_model[id].numSpec)(spec);
  if (Rf_length(r_spec) < numSpec)
    Rf_error("Item spec must be of length %d, not %d", numSpec, Rf_length(r_spec));
    
  int numParam = (*Glibrpf_model[id].numParam)(spec);
  if (Rf_length(r_param) < numParam)
    Rf_error("Item has %d parameters, only %d given", numParam, Rf_length(r_param));

  int dims = spec[RPF_ISpecDims];
  if (dims == 0) Rf_error("Item has no factors");
  if (Rf_length(r_dir) != dims)
    Rf_error("Item has %d dimensions, but dir is of length %d",
	  dims, Rf_length(r_dir));
  if (Rf_length(r_where) != dims)
    Rf_error("Item has %d dimensions, but where is of length %d",
	  dims, Rf_length(r_where));

  SEXP ret, names;
  Rf_protect(ret = Rf_allocVector(VECSXP, 2));
  Rf_protect(names = Rf_allocVector(STRSXP, 2));

  int outcomes = spec[RPF_ISpecOutcomes];
  SEXP grad, hess;
  Rf_protect(grad = Rf_allocVector(REALSXP, outcomes));
  Rf_protect(hess = Rf_allocVector(REALSXP, outcomes));
  memset(REAL(grad), 0, sizeof(double) * outcomes);
  memset(REAL(hess), 0, sizeof(double) * outcomes);
  (*Glibrpf_model[id].dTheta)(spec, REAL(r_param), REAL(r_where), REAL(r_dir),
			     REAL(grad), REAL(hess));
  SET_VECTOR_ELT(ret, 0, grad);
  SET_VECTOR_ELT(ret, 1, hess);
  SET_STRING_ELT(names, 0, Rf_mkChar("gradient"));
  SET_STRING_ELT(names, 1, Rf_mkChar("hessian"));
  Rf_namesgets(ret, names);
  UNPROTECT(4);
  return ret;
}

SEXP vflatten_impl(SEXP x, SEXP type_) {
  if (TYPEOF(x) != VECSXP) {
    stop_bad_type(x, "a list", NULL, ".x");
  }
  int m = Rf_length(x);

  SEXPTYPE type = Rf_str2type(CHAR(Rf_asChar(type_)));

  // Determine output size and type
  int n = 0;
  int has_names = 0;
  for (int j = 0; j < m; ++j) {
    SEXP x_j = VECTOR_ELT(x, j);

    n += Rf_length(x_j);
    if (!has_names && !Rf_isNull(Rf_getAttrib(x_j, R_NamesSymbol))) {
      has_names = 1;
    }
  }

  SEXP out = PROTECT(Rf_allocVector(type, n));
  SEXP names = PROTECT(Rf_allocVector(STRSXP, n));
  if (has_names)
    Rf_setAttrib(out, R_NamesSymbol, names);
  UNPROTECT(1);

  int i = 0;
  for (int j = 0; j < m; ++j) {
    SEXP x_j = VECTOR_ELT(x, j);
    int n_j = Rf_length(x_j);

    SEXP names_j = PROTECT(Rf_getAttrib(x_j, R_NamesSymbol));
    int has_names_j = !Rf_isNull(names_j);

    for (int k = 0; k < n_j; ++k, ++i) {
      set_vector_value(out, i, x_j, k);

      if (has_names)
        SET_STRING_ELT(names, i, has_names_j ? STRING_ELT(names_j, k) : Rf_mkChar(""));
      if (i % 1024 == 0)
        R_CheckUserInterrupt();
    }

    UNPROTECT(1);
  }

  UNPROTECT(1);
  return out;
}

SEXP init_Rcpp_cache(){   
    SEXP getNamespaceSym = Rf_install("getNamespace"); // cannot be gc()'ed  once in symbol table
    Rcpp::Shield<SEXP> RCPP( Rf_eval(Rf_lang2( getNamespaceSym, Rf_mkString("Rcpp") ), R_GlobalEnv) ) ;
    Rcpp::Shield<SEXP> cache( Rf_allocVector( VECSXP, RCPP_CACHE_SIZE ) );
    
    // the Rcpp namespace
	SET_VECTOR_ELT( cache, 0, RCPP ) ;
	set_error_occured( cache, Rf_ScalarLogical(FALSE) ) ; // error occured
	set_current_error( cache, R_NilValue ) ; // current error
	SET_VECTOR_ELT( cache, 3, R_NilValue ) ; // stack trace
	SET_VECTOR_ELT( cache, RCPP_HASH_CACHE_INDEX, Rf_allocVector(INTSXP, RCPP_HASH_CACHE_INITIAL_SIZE) ) ;
	Rf_defineVar( Rf_install(".rcpp_cache"), cache, RCPP );
    
	return cache ;
}

void omxPopulateFIMLAttributes(omxFitFunction *off, SEXP algebra) {
	if(OMX_DEBUG) { mxLog("Populating FIML Attributes."); }
	omxFIMLFitFunction *argStruct = ((omxFIMLFitFunction*)off->argStruct);
	SEXP expCovExt, expMeanExt, rowLikelihoodsExt;
	omxMatrix *expCovInt, *expMeanInt;
	expCovInt = argStruct->cov;
	expMeanInt = argStruct->means;
	
	Rf_protect(expCovExt = Rf_allocMatrix(REALSXP, expCovInt->rows, expCovInt->cols));
	for(int row = 0; row < expCovInt->rows; row++)
		for(int col = 0; col < expCovInt->cols; col++)
			REAL(expCovExt)[col * expCovInt->rows + row] =
				omxMatrixElement(expCovInt, row, col);
	if (expMeanInt != NULL && expMeanInt->rows > 0  && expMeanInt->cols > 0) {
		Rf_protect(expMeanExt = Rf_allocMatrix(REALSXP, expMeanInt->rows, expMeanInt->cols));
		for(int row = 0; row < expMeanInt->rows; row++)
			for(int col = 0; col < expMeanInt->cols; col++)
				REAL(expMeanExt)[col * expMeanInt->rows + row] =
					omxMatrixElement(expMeanInt, row, col);
	} else {
		Rf_protect(expMeanExt = Rf_allocMatrix(REALSXP, 0, 0));		
	}

	Rf_setAttrib(algebra, Rf_install("expCov"), expCovExt);
	Rf_setAttrib(algebra, Rf_install("expMean"), expMeanExt);
	
	if(argStruct->populateRowDiagnostics){
		omxMatrix *rowLikelihoodsInt = argStruct->rowLikelihoods;
		Rf_protect(rowLikelihoodsExt = Rf_allocVector(REALSXP, rowLikelihoodsInt->rows));
		for(int row = 0; row < rowLikelihoodsInt->rows; row++)
			REAL(rowLikelihoodsExt)[row] = omxMatrixElement(rowLikelihoodsInt, row, 0);
		Rf_setAttrib(algebra, Rf_install("likelihoods"), rowLikelihoodsExt);
	}
}

 SEXP int64_format_binary__standard(SEXP x){
     int n = Rf_length(x) ;
     SEXP res = PROTECT( Rf_allocVector( STRSXP, n ) ) ;
     
     switch( TYPEOF(x) ){ 
     case INTSXP:
         {
             int* data = INTEGER(x) ;
             for( int i=0; i<n; i++){
                 SET_STRING_ELT( res, i, Rf_mkChar( Rint64::internal::format_binary__impl<int>( data[i] ) ) ) ;
             }
             break ;
         }
     case REALSXP:
         {
             double* p_x = REAL(x) ;
             for( int i=0; i<n; i++){
                 SET_STRING_ELT( res, i, Rf_mkChar( Rint64::internal::format_binary__impl<double>( p_x[i] ) ) );
             }      
             break ;
         }
     default:
         Rf_error( "incompatible type" ) ;
     }
     UNPROTECT(1) ; // res ;
     return res ;
 }

  SEXP ToRMatrix(const Matrix &m,
                 const std::vector<std::string> &rownames,
                 const std::vector<std::string> &colnames){
    if (!rownames.empty() && rownames.size() != m.nrow()) {
      report_error("In ToRMatrix:  Vector of row names does not match "
                   "the number of rows in m.");
    } else if (!colnames.empty() && colnames.size() != m.ncol()) {
      report_error("In ToRMatrix:  Vector of column names does not match "
                   "the number of columns in m.");
    }
    SEXP ans;
    PROTECT(ans = Rf_allocMatrix(REALSXP, m.nrow(), m.ncol()));
    double *data = REAL(ans);
    std::copy(m.begin(), m.end(), data);

    SEXP r_dimnames;
    PROTECT(r_dimnames = Rf_allocVector(VECSXP, 2));
    SET_VECTOR_ELT(
        r_dimnames,
        0,
        rownames.empty() ? R_NilValue : CharacterVector(rownames));
    SET_VECTOR_ELT(
        r_dimnames,
        1,
        colnames.empty() ? R_NilValue : CharacterVector(colnames));
    Rf_dimnamesgets(ans, r_dimnames);
    UNPROTECT(2);
    return ans;
  }

extern "C" SEXP int64_limits( SEXP type_ ){
    const char* type = CHAR(STRING_ELT(type_, 0) ) ;
    
    if( !strncmp( type, "integer", 7 ) ){                                      
        SEXP res = PROTECT( Rf_allocVector(INTSXP, 2 ) ) ;
        INTEGER(res)[0] = std::numeric_limits<int>::min() + 1 ;
        INTEGER(res)[1] = std::numeric_limits<int>::max() ;
        UNPROTECT(1) ;
        return res ;
    } else if( ! strncmp( type, "int64", 5 ) ){
        return Rint64::internal::new_long_2<int64_t>( 
            Rint64::internal::long_traits<int64_t>::min() , 
            Rint64::internal::long_traits<int64_t>::max() 
            ) ;
    } else if( !strncmp( type, "uint64", 6 ) ){
        return Rint64::internal::new_long_2<uint64_t>( 
            Rint64::internal::long_traits<uint64_t>::min(), 
            Rint64::internal::long_traits<uint64_t>::max()
            ) ;                                    
    }
    
    
    Rf_error( "unsupported type" ) ;
    return R_NilValue ;
}

 SEXP appendListElements(SEXP r_list,
                         const std::vector<SEXP> &new_elements,
                         const std::vector<std::string> &new_element_names) {
   if (new_element_names.size() != new_elements.size()) {
     report_error("In appendListElements:  The vector of new elements must "
                  "be the same size as the vector of new element names.");
   }
   int original_list_length = Rf_length(r_list);
   SEXP ans;
   PROTECT(ans = Rf_allocVector(
       VECSXP, original_list_length + new_elements.size()));
   for (int i = 0; i < original_list_length; ++i) {
     SET_VECTOR_ELT(ans, i, VECTOR_ELT(r_list, i));
   }
   for (int i = 0; i < new_elements.size(); ++i) {
     SET_VECTOR_ELT(ans, i + original_list_length,
                    new_elements[i]);
   }
   std::vector<std::string> new_list_names = getListNames(r_list);
   for (int i = 0; i < new_element_names.size(); ++i) {
     new_list_names.push_back(new_element_names[i]);
   }
   ans = setListNames(ans, new_list_names);
   UNPROTECT(1);
   return ans;
 }

/** Count the number of BreakIterator boundaries
 *
 * @param str character vector
 * @param opts_brkiter identifier
 * @return character vector
 *
 * @version 0.3-1 (Marek Gagolewski, 2014-10-30)
 *
 * @version 0.3-1 (Marek Gagolewski, 2014-11-04)
 *    Issue #112: str_prepare_arg* retvals were not PROTECTed from gc
 *
 * @version 0.4-1 (Marek Gagolewski, 2014-12-02)
 *          use StriRuleBasedBreakIterator
 */
SEXP stri_count_boundaries(SEXP str, SEXP opts_brkiter)
{
   PROTECT(str = stri_prepare_arg_string(str, "str"));
   StriBrkIterOptions opts_brkiter2(opts_brkiter, "line_break");

   STRI__ERROR_HANDLER_BEGIN(1)
   R_len_t str_length = LENGTH(str);
   StriContainerUTF8_indexable str_cont(str, str_length);

   SEXP ret;
   STRI__PROTECT(ret = Rf_allocVector(INTSXP, str_length));
   StriRuleBasedBreakIterator brkiter(opts_brkiter2);

   for (R_len_t i = 0; i < str_length; ++i)
   {
      if (str_cont.isNA(i)) {
         INTEGER(ret)[i] = NA_INTEGER;
         continue;
      }

      brkiter.setupMatcher(str_cont.get(i).c_str(), str_cont.get(i).length());
      brkiter.first();

      R_len_t cur_count = 0;
      while (brkiter.next())
         ++cur_count;

      INTEGER(ret)[i] = cur_count;
   }

   STRI__UNPROTECT_ALL
   return ret;
   STRI__ERROR_HANDLER_END({ /* no action */  })
}

SEXP createTrace(arglistT& arglist, vpArmaMapT& armaMap, vpMCMCMapT& mcmcMap) {
    SEXP ans;
    PROTECT(ans = Rf_allocVector(VECSXP, arglist.size()));
    for(size_t i = 0; i < arglist.size(); i++) {
        ArmaContext* ap = armaMap[rawAddress(arglist[i])];
        cppbugs::MCMCObject* node = mcmcMap[rawAddress(arglist[i])];
        if(!node->isObserved()) {
            switch(ap->getArmaType()) {
            case doubleT:
                SET_VECTOR_ELT(ans,i,getHistory<double>(node));
                break;
            case vecT:
                SET_VECTOR_ELT(ans,i,getHistory<arma::vec>(node));
                break;
            case matT:
            default:
                SET_VECTOR_ELT(ans,i,R_NilValue);
            }
        } else {
            SET_VECTOR_ELT(ans,i,R_NilValue);
        }
    }
    UNPROTECT(1);
    return ans;
}

/**
 * Reverse Each String
 * @param str character vector
 * @return character vector with every string reversed
 *
 *
 * @version 0.1-?? (Bartek Tartanus)
 *
 * @version 0.1-?? (Marek Gagolewski)
 *          use StriContainerUTF16
 *
 * @version 0.1-?? (Marek Gagolewski, 2013-06-16)
 *          make StriException-friendly + StriContainerUTF8 (bug fix, do reversing manually)
 *
 * @version 0.2-1 (Marek Gagolewski, 2014-04-01)
 *          detect incorrect utf8 byte stream
 *
 * @version 0.3-1 (Marek Gagolewski, 2014-11-04)
 *    Issue #112: str_prepare_arg* retvals were not PROTECTed from gc
 */
SEXP stri_reverse(SEXP str)
{
   PROTECT(str = stri_prepare_arg_string(str, "str"));    // prepare string argument

   STRI__ERROR_HANDLER_BEGIN(1)
   R_len_t str_len = LENGTH(str);
   StriContainerUTF8 str_cont(str, str_len); // writable, no recycle

   // STEP 1.
   // Calculate the required buffer length
   R_len_t bufsize = 0;
   for (R_len_t i=0; i<str_len; ++i) {
      if (str_cont.isNA(i))
         continue;

      R_len_t cursize = str_cont.get(i).length();
      if (cursize > bufsize)
         bufsize = cursize;
   }

   // STEP 2.
   // Alloc buffer & result vector
   String8buf buf(bufsize);
   SEXP ret;
   STRI__PROTECT(ret = Rf_allocVector(STRSXP, str_len));

   for (R_len_t i = str_cont.vectorize_init();
         i != str_cont.vectorize_end();
         i = str_cont.vectorize_next(i))
   {
      if (str_cont.isNA(i)) {
         SET_STRING_ELT(ret, i, NA_STRING);
         continue;
      }

      R_len_t str_cur_n = str_cont.get(i).length();
      const char* str_cur_s = str_cont.get(i).c_str();

      R_len_t j, k;
      UChar32 chr;
      UBool isError = FALSE;

      for (j=str_cur_n, k=0; !isError && j>0; ) {
         U8_PREV(str_cur_s, 0, j, chr); // go backwards
         if (chr < 0) {
            throw StriException(MSG__INVALID_UTF8);
         }
         U8_APPEND((uint8_t*)buf.data(), k, str_cur_n, chr, isError);
      }

      if (isError)
         throw StriException(MSG__INTERNAL_ERROR);

      SET_STRING_ELT(ret, i, Rf_mkCharLenCE(buf.data(), str_cur_n, CE_UTF8));
   }

   STRI__UNPROTECT_ALL
   return ret;
   STRI__ERROR_HANDLER_END(;/* nothing special to be done on error */)
}

/** Get the symmetric closure of a binary relation
 *
 * @param x square logical matrix
 * @return square logical matrix
 *
 * @version 0.2 (Marek Gagolewski)
 */
SEXP rel_closure_symmetric(SEXP x)
{
    x = prepare_arg_logical_square_matrix(x, "R");
    SEXP dim = Rf_getAttrib(x, R_DimSymbol);
    R_len_t n = INTEGER(dim)[0];
    int* xp = INTEGER(x);

    SEXP y = Rf_allocVector(LGLSXP, n*n);
    int* yp = INTEGER(y);
    Rf_setAttrib(y, R_DimSymbol, dim);
    Rf_setAttrib(y, R_DimNamesSymbol, Rf_getAttrib(x, R_DimNamesSymbol)); // preserve dimnames

    for (R_len_t i=0; i<n*n; ++i) {
        if (xp[i] == NA_LOGICAL)
            Rf_error(MSG__ARG_EXPECTED_NOT_NA, "R"); // missing values are not allowed
        yp[i] = xp[i];
    }

    for (R_len_t i=0; i<n-1; ++i) {
        for (R_len_t j=i+1; j<n; ++j) {
            if (yp[i+n*j] && !yp[j+n*i])
                yp[j+n*i] = TRUE;
            else if (yp[j+n*i] && !yp[i+n*j])
                yp[i+n*j] = TRUE;
        }
    }

    return y;
}

static void omxCallRFitFunction(omxFitFunction *oo, int want, FitContext *) {
	if (want & (FF_COMPUTE_PREOPTIMIZE)) return;

	omxRFitFunction* rFitFunction = (omxRFitFunction*)oo->argStruct;

	SEXP theCall, theReturn;
	ScopedProtect p2(theCall, Rf_allocVector(LANGSXP, 3));
	SETCAR(theCall, rFitFunction->fitfun);
	SETCADR(theCall, rFitFunction->model);
	SETCADDR(theCall, rFitFunction->state);

	{
		ScopedProtect p1(theReturn, Rf_eval(theCall, R_GlobalEnv));

	if (LENGTH(theReturn) < 1) {
		// seems impossible, but report it if it happens
		omxRaiseErrorf("FitFunction returned nothing");
	} else if (LENGTH(theReturn) == 1) {
		oo->matrix->data[0] = Rf_asReal(theReturn);
	} else if (LENGTH(theReturn) == 2) {
		oo->matrix->data[0] = Rf_asReal(VECTOR_ELT(theReturn, 0));
		R_Reprotect(rFitFunction->state = VECTOR_ELT(theReturn, 1), rFitFunction->stateIndex);
	} else if (LENGTH(theReturn) > 2) {
		omxRaiseErrorf("FitFunction returned more than 2 arguments");
	}
	}
}

SEXP r_as_floatraw(SEXP x)
{
  SEXP ans;
  int i, n;
  double *dp;
  float  *fp;

  dp = (double*) REAL(x);

  n = LENGTH(x);
  if (n < 1) {
    error("length of x should be >= 1");
    return R_NilValue;
  }

  ans = PROTECT( Rf_allocVector(RAWSXP, sizeof(float)*n) );

  fp = (float*) RAW(ans);

  for(i = 0 ; i < n ; ++i )
    fp[i] = (float) dp[i];

  UNPROTECT(1);
  return ans;
}