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;
}
SEXP getPosixClasses(){
SEXP datetimeclass = PROTECT(Rf_allocVector(STRSXP,2));
SET_STRING_ELT(datetimeclass, 0, Rf_mkChar("POSIXct"));
SET_STRING_ELT(datetimeclass, 1, Rf_mkChar("POSIXt"));
UNPROTECT(1) ;
return datetimeclass ;
}
/**
* 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 transitive closure of a binary relation
*
* @param x square logical matrix
* @return square logical matrix
*
* @version 0.2 (Marek Gagolewski)
*/
SEXP rel_closure_transitive(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 k=0; k<n; ++k) { // Warshall's algorithm
for (R_len_t i=0; i<n; ++i) {
for (R_len_t j=0; j<n; ++j) {
yp[i+n*j] = (yp[i+n*j] || (yp[i+n*k] && yp[k+n*j]));
}
}
}
return y;
}
/** 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;
}
/**
* Split a string into parts.
*
* The pattern matches identify delimiters that separate the input into fields.
* The input data between the matches becomes the fields themselves.
*
* @param str character vector
* @param pattern character vector
* @param n_max integer vector
* @param opts_regex
* @return list of character vectors
*
* @version 0.1 (Marek Gagolewski, 2013-06-21)
* @version 0.2 (Marek Gagolewski, 2013-07-10) - BUGFIX: wrong behavior on empty str
*/
SEXP stri_split_regex(SEXP str, SEXP pattern, SEXP n_max, SEXP omit_empty, SEXP opts_regex)
{
str = stri_prepare_arg_string(str, "str");
pattern = stri_prepare_arg_string(pattern, "pattern");
n_max = stri_prepare_arg_integer(n_max, "n_max");
omit_empty = stri_prepare_arg_logical(omit_empty, "omit_empty");
R_len_t vectorize_length = stri__recycling_rule(true, 4, LENGTH(str), LENGTH(pattern), LENGTH(n_max), LENGTH(omit_empty));
uint32_t pattern_flags = StriContainerRegexPattern::getRegexFlags(opts_regex);
UText* str_text = NULL; // may potentially be slower, but definitely is more convenient!
STRI__ERROR_HANDLER_BEGIN
StriContainerUTF8 str_cont(str, vectorize_length);
StriContainerInteger n_max_cont(n_max, vectorize_length);
StriContainerLogical omit_empty_cont(omit_empty, vectorize_length);
StriContainerRegexPattern pattern_cont(pattern, vectorize_length, pattern_flags);
SEXP ret;
PROTECT(ret = Rf_allocVector(VECSXP, vectorize_length));
for (R_len_t i = pattern_cont.vectorize_init();
i != pattern_cont.vectorize_end();
i = pattern_cont.vectorize_next(i))
{
if (n_max_cont.isNA(i) || omit_empty_cont.isNA(i)) {
SET_VECTOR_ELT(ret, i, stri__vector_NA_strings(1));
continue;
}
int n_max_cur = n_max_cont.get(i);
int omit_empty_cur = omit_empty_cont.get(i);
STRI__CONTINUE_ON_EMPTY_OR_NA_STR_PATTERN(str_cont, pattern_cont,
SET_VECTOR_ELT(ret, i, stri__vector_NA_strings(1));,
SET_VECTOR_ELT(ret, i, stri__vector_empty_strings((omit_empty_cur || n_max_cur == 0)?0:1));)
/** Locate all BreakIterator boundaries
*
* @param str character vector
* @param omit_no_match logical
* @param opts_brkiter named list
* @return list
*
* @version 0.2-2 (Marek Gagolewski, 2014-04-22)
*
* @version 0.2-2 (Marek Gagolewski, 2014-04-23)
* removed "title": For Unicode 4.0 and above title boundary
* iteration, please use Word Boundary iterator.
*
* @version 0.2-2 (Marek Gagolewski, 2014-04-25)
* use stri__split_or_locate_boundaries
*
* @version 0.3-1 (Marek Gagolewski, 2014-10-29)
* use opts_brkiter
*
* @version 0.4-1 (Marek Gagolewski, 2014-11-28)
* new args: omit_no_match
*
* @version 0.4-1 (Marek Gagolewski, 2014-12-02)
* use StriRuleBasedBreakIterator
*/
SEXP stri_locate_all_boundaries(SEXP str, SEXP omit_no_match, SEXP opts_brkiter)
{
bool omit_no_match1 = stri__prepare_arg_logical_1_notNA(omit_no_match, "omit_no_match");
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);
StriRuleBasedBreakIterator brkiter(opts_brkiter2);
SEXP ret;
STRI__PROTECT(ret = Rf_allocVector(VECSXP, str_length));
for (R_len_t i = 0; i < str_length; ++i)
{
if (str_cont.isNA(i)) {
SET_VECTOR_ELT(ret, i, stri__matrix_NA_INTEGER(1, 2));
continue;
}
brkiter.setupMatcher(str_cont.get(i).c_str(), str_cont.get(i).length());
brkiter.first();
deque< pair<R_len_t,R_len_t> > occurrences;
pair<R_len_t,R_len_t> curpair;
while (brkiter.next(curpair))
occurrences.push_back(curpair);
R_len_t noccurrences = (R_len_t)occurrences.size();
if (noccurrences <= 0) {
SET_VECTOR_ELT(ret, i, stri__matrix_NA_INTEGER(omit_no_match1?0:1, 2));
continue;
}
SEXP ans;
STRI__PROTECT(ans = Rf_allocMatrix(INTSXP, noccurrences, 2));
int* ans_tab = INTEGER(ans);
deque< pair<R_len_t, R_len_t> >::iterator iter = occurrences.begin();
for (R_len_t j = 0; iter != occurrences.end(); ++iter, ++j) {
pair<R_len_t, R_len_t> cur_match = *iter;
ans_tab[j] = cur_match.first;
ans_tab[j+noccurrences] = cur_match.second;
}
// Adjust UChar index -> UChar32 index (1-2 byte UTF16 to 1 byte UTF32-code points)
str_cont.UTF8_to_UChar32_index(i, ans_tab,
ans_tab+noccurrences, noccurrences,
1, // 0-based index -> 1-based
0 // end returns position of next character after match
);
SET_VECTOR_ELT(ret, i, ans);
STRI__UNPROTECT(1);
}
stri__locate_set_dimnames_list(ret);
STRI__UNPROTECT_ALL
return ret;
STRI__ERROR_HANDLER_END({ /* nothing special t.b.d. on error */ })
}
/**
* Split a string into parts [byte compare]
*
* The pattern matches identify delimiters that separate the input into fields.
* The input data between the matches becomes the fields themselves.
*
* @param str character vector
* @param pattern character vector
* @param n_max integer vector
* @param omit_empty logical vector
*
*
* @version 0.1 (Bartek Tartanus)
* @version 0.2 (Marek Gagolewski, 2013-06-25) StriException friendly, use StriContainerUTF8
* @version 0.3 (Marek Gagolewski, 2013-07-10) - BUGFIX: wrong behavior on empty str
*/
SEXP stri__split_fixed_byte(SEXP str, SEXP pattern, SEXP n_max, SEXP omit_empty)
{
str = stri_prepare_arg_string(str, "str");
pattern = stri_prepare_arg_string(pattern, "pattern");
n_max = stri_prepare_arg_integer(n_max, "n_max");
omit_empty = stri_prepare_arg_logical(omit_empty, "omit_empty");
STRI__ERROR_HANDLER_BEGIN
R_len_t vectorize_length = stri__recycling_rule(true, 4, LENGTH(str), LENGTH(pattern), LENGTH(n_max), LENGTH(omit_empty));
StriContainerUTF8 str_cont(str, vectorize_length);
StriContainerByteSearch pattern_cont(pattern, vectorize_length);
StriContainerInteger n_max_cont(n_max, vectorize_length);
StriContainerLogical omit_empty_cont(omit_empty, vectorize_length);
SEXP ret;
PROTECT(ret = Rf_allocVector(VECSXP, vectorize_length));
for (R_len_t i = pattern_cont.vectorize_init();
i != pattern_cont.vectorize_end();
i = pattern_cont.vectorize_next(i))
{
if (n_max_cont.isNA(i) || omit_empty_cont.isNA(i)) {
SET_VECTOR_ELT(ret, i, stri__vector_NA_strings(1));
continue;
}
int n_max_cur = n_max_cont.get(i);
int omit_empty_cur = omit_empty_cont.get(i);
STRI__CONTINUE_ON_EMPTY_OR_NA_STR_PATTERN(str_cont, pattern_cont,
SET_VECTOR_ELT(ret, i, stri__vector_NA_strings(1)); ,
SET_VECTOR_ELT(ret, i, stri__vector_empty_strings((omit_empty_cur || n_max_cur == 0)?0:1));)
/**
* Detect if a pattern occurs in a string
*
* @param str R character vector
* @param pattern R character vector containing regular expressions
* @param opts_regex list
*
* @version 0.1 (Marcin Bujarski)
* @version 0.2 (Marek Gagolewski) - use StriContainerUTF16
* @version 0.3 (Marek Gagolewski) - use StriContainerUTF16's vectorization
* @version 0.4 (Marek Gagolewski, 2013-06-18) use StriContainerRegexPattern + opts_regex
*/
SEXP stri_detect_regex(SEXP str, SEXP pattern, SEXP opts_regex)
{
str = stri_prepare_arg_string(str, "str");
pattern = stri_prepare_arg_string(pattern, "pattern");
R_len_t vectorize_length = stri__recycling_rule(true, 2, LENGTH(str), LENGTH(pattern));
// this will work for vectorize_length == 0:
uint32_t pattern_flags = StriContainerRegexPattern::getRegexFlags(opts_regex);
STRI__ERROR_HANDLER_BEGIN
StriContainerUTF16 str_cont(str, vectorize_length);
// MG: tried StriContainerUTF8 + utext_openUTF8 - this was slower
StriContainerRegexPattern pattern_cont(pattern, vectorize_length, pattern_flags);
SEXP ret;
PROTECT(ret = Rf_allocVector(LGLSXP, vectorize_length));
int* ret_tab = LOGICAL(ret);
for (R_len_t i = pattern_cont.vectorize_init();
i != pattern_cont.vectorize_end();
i = pattern_cont.vectorize_next(i))
{
STRI__CONTINUE_ON_EMPTY_OR_NA_STR_PATTERN(str_cont, pattern_cont, ret_tab[i] = NA_LOGICAL, ret_tab[i] = FALSE)
RegexMatcher *matcher = pattern_cont.getMatcher(i); // will be deleted automatically
matcher->reset(str_cont.get(i));
ret_tab[i] = (int)matcher->find();
}
UNPROTECT(1);
return ret;
STRI__ERROR_HANDLER_END(;/* nothing special to be done on error */)
}
/**
* List stashes in a repository
*
* @param repo S3 class git_repository
* @return VECXSP with S3 objects of class git_stash
*/
SEXP git2r_stash_list(SEXP repo)
{
SEXP list = R_NilValue;
int error, nprotect = 0;
git2r_stash_list_cb_data cb_data = {0, R_NilValue, R_NilValue, NULL};
git_repository *repository = NULL;
repository = git2r_repository_open(repo);
if (!repository)
git2r_error(__func__, NULL, git2r_err_invalid_repository, NULL);
/* Count number of stashes before creating the list */
error = git_stash_foreach(repository, &git2r_stash_list_cb, &cb_data);
if (error)
goto cleanup;
PROTECT(list = Rf_allocVector(VECSXP, cb_data.n));
nprotect++;
cb_data.n = 0;
cb_data.list = list;
cb_data.repo = repo;
cb_data.repository = repository;
error = git_stash_foreach(repository, &git2r_stash_list_cb, &cb_data);
cleanup:
git_repository_free(repository);
if (nprotect)
UNPROTECT(nprotect);
if (error)
git2r_error(__func__, GIT2R_ERROR_LAST(), NULL, NULL);
return list;
}
/**
* Count the number of recurrences of \code{pattern} in \code{str} [fast but dummy bitewise compare]
*
* @param str strings to search in
* @param pattern patterns to search for
* @return integer vector
*
* @version 0.1 (Bartek Tartanus)
* @version 0.2 (Marek Gagolewski) - use StriContainerUTF8
* @version 0.3 (Marek Gagolewski) - corrected behavior on empty str/pattern
* @version 0.4 (Marek Gagolewski, 2013-06-23) make StriException-friendly,
* use StriContainerByteSearch
*/
SEXP stri__count_fixed_byte(SEXP str, SEXP pattern)
{
str = stri_prepare_arg_string(str, "str");
pattern = stri_prepare_arg_string(pattern, "pattern");
STRI__ERROR_HANDLER_BEGIN
R_len_t vectorize_length = stri__recycling_rule(true, 2, LENGTH(str), LENGTH(pattern));
StriContainerUTF8 str_cont(str, vectorize_length);
StriContainerByteSearch pattern_cont(pattern, vectorize_length);
SEXP ret;
PROTECT(ret = Rf_allocVector(INTSXP, vectorize_length));
int* ret_tab = INTEGER(ret);
for (R_len_t i = pattern_cont.vectorize_init();
i != pattern_cont.vectorize_end();
i = pattern_cont.vectorize_next(i))
{
STRI__CONTINUE_ON_EMPTY_OR_NA_STR_PATTERN(str_cont, pattern_cont,
ret_tab[i] = NA_INTEGER, ret_tab[i] = 0)
pattern_cont.setupMatcher(i, str_cont.get(i).c_str(), str_cont.get(i).length());
ret_tab[i] = 0;
while (USEARCH_DONE != pattern_cont.findNext())
++ret_tab[i];
}
UNPROTECT(1);
return ret;
STRI__ERROR_HANDLER_END( ;/* do nothing special on error */ )
}
// use this constructor for new fts objects
BackendBase(SEXPTYPE rtype, R_len_t nr, R_len_t nc) : Robject(PROTECT(Rf_allocMatrix(rtype, nr, nc))) {
// add fts class to Robject
SEXP r_tseries_class = PROTECT(Rf_allocVector(STRSXP, 2));
SET_STRING_ELT(r_tseries_class, 0, Rf_mkChar("fts"));
SET_STRING_ELT(r_tseries_class, 1, Rf_mkChar("zoo"));
Rf_classgets(Robject, r_tseries_class);
UNPROTECT(1); // r_tseries_class
}
SEXP MxRList::asR()
{
// detect duplicate keys? TODO
SEXP names, ans;
int len = size();
Rf_protect(names = Rf_allocVector(STRSXP, len));
Rf_protect(ans = Rf_allocVector(VECSXP, len));
for (int lx=0; lx < len; ++lx) {
const char *p1 = (*this)[lx].first;
SEXP p2 = (*this)[lx].second;
if (!p1 || !p2) Rf_error("Attempt to return NULL pointer to R");
SET_STRING_ELT(names, lx, Rf_mkChar(p1));
SET_VECTOR_ELT(ans, lx, p2);
}
Rf_namesgets(ans, names);
return ans;
}
// [[Rcpp::export]]
SEXP get_volume(std::string filename){
MincVolume vol(filename);
SEXP res = PROTECT(Rf_allocVector(REALSXP, vol.size()));
double* real_res = REAL(res);
vol.read_volume_to_buffer(real_res, MI_TYPE_DOUBLE);
UNPROTECT(1);
return(res);
}
SEXP ocl_get_platform_info(SEXP platform) {
SEXP res;
cl_platform_id platform_id = getPlatformID(platform);
const char *names[] = { "name", "vendor", "version", "profile", "exts" };
SEXP nv = PROTECT(Rf_allocVector(STRSXP, 5));
int i;
for (i = 0; i < LENGTH(nv); i++) SET_STRING_ELT(nv, i, mkChar(names[i]));
res = PROTECT(Rf_allocVector(VECSXP, LENGTH(nv)));
Rf_setAttrib(res, R_NamesSymbol, nv);
SET_VECTOR_ELT(res, 0, getPlatformInfo(platform_id, CL_PLATFORM_NAME));
SET_VECTOR_ELT(res, 1, getPlatformInfo(platform_id, CL_PLATFORM_VENDOR));
SET_VECTOR_ELT(res, 2, getPlatformInfo(platform_id, CL_PLATFORM_VERSION));
SET_VECTOR_ELT(res, 3, getPlatformInfo(platform_id, CL_PLATFORM_PROFILE));
SET_VECTOR_ELT(res, 4, getPlatformInfo(platform_id, CL_PLATFORM_EXTENSIONS));
UNPROTECT(2);
return res;
}
static SEXP get_exception_classes( const std::string& ex_class) {
Scoped<SEXP> res = Rf_allocVector( STRSXP, 4 );
SET_STRING_ELT( res, 0, Rf_mkChar( ex_class.c_str() ) ) ;
SET_STRING_ELT( res, 1, Rf_mkChar( "C++Error" ) ) ;
SET_STRING_ELT( res, 2, Rf_mkChar( "error" ) ) ;
SET_STRING_ELT( res, 3, Rf_mkChar( "condition" ) ) ;
return res;
}
/**
* Get all available ICU charsets and their aliases (elems 2,3,...)
*
* @return R list object; element name == ICU charset canonical name;
* elements are character vectors (aliases)
*
* @version 0.1-?? (Marek Gagolewski)
*
* @version 0.2-1 (Marek Gagolewski)
* use StriUcnv; make StriException-friendly
*
* @version 0.3-1 (Marek Gagolewski, 2014-11-04)
* Issue #112: str_prepare_arg* retvals were not PROTECTed from gc
*/
SEXP stri_enc_list()
{
R_len_t c = (R_len_t)ucnv_countAvailable();
STRI__ERROR_HANDLER_BEGIN(0)
SEXP ret;
SEXP names;
STRI__PROTECT(ret = Rf_allocVector(VECSXP, c));
STRI__PROTECT(names = Rf_allocVector(STRSXP, c));
for (R_len_t i=0; i<c; ++i) {
const char* canonical_name = ucnv_getAvailableName(i);
if (!canonical_name) {
SET_STRING_ELT(names, i, NA_STRING);
continue;
}
SET_STRING_ELT(names, i, Rf_mkChar(canonical_name));
UErrorCode status = U_ZERO_ERROR;
R_len_t ci = (R_len_t)ucnv_countAliases(canonical_name, &status);
if (U_FAILURE(status) || ci <= 0)
SET_VECTOR_ELT(ret, i, Rf_ScalarString(NA_STRING));
else {
SEXP aliases;
STRI__PROTECT(aliases = Rf_allocVector(STRSXP, ci));
for (R_len_t j=0; j<ci; ++j) {
status = U_ZERO_ERROR;
const char* alias = ucnv_getAlias(canonical_name, j, &status);
if (U_FAILURE(status) || !alias)
SET_STRING_ELT(aliases, j, NA_STRING);
else
SET_STRING_ELT(aliases, j, Rf_mkChar(alias));
}
SET_VECTOR_ELT(ret, i, aliases);
STRI__UNPROTECT(1);
}
}
Rf_setAttrib(ret, R_NamesSymbol, names);
STRI__UNPROTECT_ALL
return ret;
STRI__ERROR_HANDLER_END({/* no special action on error */})
}
// this is a non-throwing version returning an error code
int RInside::parseEval(const std::string & line, SEXP & ans) {
ParseStatus status;
SEXP cmdSexp, cmdexpr = R_NilValue;
int i, errorOccurred;
mb_m.add((char*)line.c_str());
PROTECT(cmdSexp = Rf_allocVector(STRSXP, 1));
SET_STRING_ELT(cmdSexp, 0, Rf_mkChar(mb_m.getBufPtr()));
cmdexpr = PROTECT(R_ParseVector(cmdSexp, -1, &status, R_NilValue));
switch (status){
case PARSE_OK:
// Loop is needed here as EXPSEXP might be of length > 1
for(i = 0; i < Rf_length(cmdexpr); i++){
ans = R_tryEval(VECTOR_ELT(cmdexpr, i), *global_env_m, &errorOccurred);
if (errorOccurred) {
if (verbose_m) Rf_warning("%s: Error in evaluating R code (%d)\n", programName, status);
UNPROTECT(2);
mb_m.rewind();
return 1;
}
if (verbose_m) {
Rf_PrintValue(ans);
}
}
mb_m.rewind();
break;
case PARSE_INCOMPLETE:
// need to read another line
break;
case PARSE_NULL:
if (verbose_m) Rf_warning("%s: ParseStatus is null (%d)\n", programName, status);
UNPROTECT(2);
mb_m.rewind();
return 1;
break;
case PARSE_ERROR:
if (verbose_m) Rf_warning("Parse Error: \"%s\"\n", line.c_str());
UNPROTECT(2);
mb_m.rewind();
return 1;
break;
case PARSE_EOF:
if (verbose_m) Rf_warning("%s: ParseStatus is eof (%d)\n", programName, status);
break;
default:
if (verbose_m) Rf_warning("%s: ParseStatus is not documented %d\n", programName, status);
UNPROTECT(2);
mb_m.rewind();
return 1;
break;
}
UNPROTECT(2);
return 0;
}
