/** Check if two vectors are comonotonic
*
* @param x numeric vector
* @param y numeric vector
* @param incompatible_lengths single logical value
* @return logical scalar
*
* @version 0.2-1 (Marek Gagolewski)
*
* @version 0.2-1 (Marek Gagolewski, 2014-11-19)
* incompatible_lenghts arg added
*/
SEXP check_comonotonicity(SEXP x, SEXP y, SEXP incompatible_lengths)
{
x = prepare_arg_numeric(x, "x");
y = prepare_arg_numeric(y, "y");
incompatible_lengths = prepare_arg_logical_1(incompatible_lengths, "incompatible_lengths");
R_len_t x_length = LENGTH(x);
R_len_t y_length = LENGTH(y);
if (x_length != y_length)
return incompatible_lengths;
double* x_tab = REAL(x);
double* y_tab = REAL(y);
for (R_len_t i=0; i<x_length; ++i) {
if (ISNA(x_tab[i]) || ISNA(y_tab[i]))
return Rf_ScalarLogical(NA_LOGICAL);
for (R_len_t j=i; j<x_length; ++j) {
if ((x_tab[i]-x_tab[j])*(y_tab[i]-y_tab[j]) < 0.0)
return Rf_ScalarLogical(FALSE);
}
}
return Rf_ScalarLogical(TRUE);
}
/** Check if a binary relation is cyclic
*
* @param x square logical matrix
* @return logical scalar
*
* @version 0.2 (Marek Gagolewski)
*/
SEXP rel_is_cyclic(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);
for (int i=0; i<n*n; ++i)
if (xp[i] == NA_LOGICAL)
return Rf_ScalarLogical(NA_LOGICAL);
int* helper = new int[n];
for (int i=0; i<n; ++i)
helper[i] = 0;
bool ret = false;
int i=0;
do {
while (i < n) { if (helper[i] == 0) break; i++; } // get an unmarked node
if (i == n) break;
ret = rel_is_cyclic(i, xp, n, helper);
} while(!ret);
delete[] helper;
return Rf_ScalarLogical(ret);
}
/** Check if a binary relation is irreflexive
*
* @param x square logical matrix
* @return logical scalar
*
* @version 0.2 (Marek Gagolewski)
*/
SEXP rel_is_irreflexive(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);
for (R_len_t i=0; i<n; ++i) {
if (xp[i+i*n] == NA_LOGICAL)
return Rf_ScalarLogical(NA_LOGICAL);
else if (xp[i+i*n])
return Rf_ScalarLogical(FALSE);
}
return Rf_ScalarLogical(TRUE);
}
/**
* Return compile time options for libgit2.
*
* @return A VECSXP with threads, https and ssh set to TRUE/FALSE
*/
SEXP git2r_libgit2_features(void)
{
const char *names[] = {"threads", "https", "ssh", ""};
int value = git_libgit2_features();
SEXP features;
PROTECT(features = Rf_mkNamed(VECSXP, names));
SET_VECTOR_ELT(features, 0, Rf_ScalarLogical(value & GIT_FEATURE_THREADS));
SET_VECTOR_ELT(features, 1, Rf_ScalarLogical(value & GIT_FEATURE_HTTPS));
SET_VECTOR_ELT(features, 2, Rf_ScalarLogical(value & GIT_FEATURE_SSH));
UNPROTECT(1);
return features;
}
SEXP audio_close(SEXP instance) {
if (TYPEOF(instance) != EXTPTRSXP)
Rf_error("invalid audio instance");
audio_instance_t *p = (audio_instance_t *) EXTPTR_PTR(instance);
if (!p) Rf_error("invalid audio instance");
return Rf_ScalarLogical((p->driver)->close(p));
}
static SEXP has_openmp()
{
#if defined(_OPENMP)
bool opm = true;
#else
bool opm = false;
#endif
return Rf_ScalarLogical(opm);
}
/** Check if a binary relation is antisymmetric
*
* @param x square logical matrix
* @return logical scalar
*
* @version 0.2 (Marek Gagolewski)
*/
SEXP rel_is_antisymmetric(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);
for (R_len_t i=0; i<n-1; ++i) {
for (R_len_t j=i+1; j<n; ++j) {
if (xp[j+i*n] == NA_LOGICAL && (xp[i+j*n] == NA_LOGICAL || xp[i+j*n]))
return Rf_ScalarLogical(NA_LOGICAL);
else if (xp[i+j*n] == NA_LOGICAL && (xp[j+i*n] == NA_LOGICAL || xp[j+i*n]))
return Rf_ScalarLogical(NA_LOGICAL);
else if (xp[i+j*n] != NA_LOGICAL && xp[j+i*n] != NA_LOGICAL && xp[i+j*n] && xp[j+i*n])
return Rf_ScalarLogical(FALSE);
}
}
return Rf_ScalarLogical(TRUE);
}
SEXP R_mongo_collection_drop (SEXP ptr){
mongoc_collection_t *col = r2col(ptr);
bson_error_t err;
int res = mongoc_collection_drop(col, &err);
if(!res && err.code != 26)
stop(err.message);
return Rf_ScalarLogical(res);
}
SEXP R_mongo_collection_drop_index(SEXP ptr_col, SEXP name) {
mongoc_collection_t *col = r2col(ptr_col);
const char *str = Rf_translateCharUTF8(Rf_asChar(name));
bson_error_t err;
if(!mongoc_collection_drop_index(col, str, &err))
stop(err.message);
return Rf_ScalarLogical(1);
}
SEXP R_mongo_collection_rename(SEXP ptr_col, SEXP db, SEXP name) {
mongoc_collection_t *col = r2col(ptr_col);
bson_error_t err;
const char *new_db = NULL;
if(db != R_NilValue)
new_db = Rf_translateCharUTF8(Rf_asChar(db));
if(!mongoc_collection_rename(col, new_db, Rf_translateCharUTF8(Rf_asChar(name)), false, &err))
stop(err.message);
return Rf_ScalarLogical(1);
}
SEXP R_mongo_collection_remove(SEXP ptr_col, SEXP ptr_bson, SEXP just_one){
mongoc_collection_t *col = r2col(ptr_col);
bson_t *b = r2bson(ptr_bson);
bson_error_t err;
mongoc_remove_flags_t flags = Rf_asLogical(just_one) ? MONGOC_REMOVE_SINGLE_REMOVE : MONGOC_REMOVE_NONE;
if(!mongoc_collection_remove(col, flags, b, NULL, &err))
stop(err.message);
return Rf_ScalarLogical(1);
}
SEXP R_mongo_collection_insert_bson(SEXP ptr_col, SEXP ptr_bson, SEXP stop_on_error){
mongoc_collection_t *col = r2col(ptr_col);
bson_t *b = r2bson(ptr_bson);
mongoc_insert_flags_t flags = Rf_asLogical(stop_on_error) ? MONGOC_INSERT_NONE : MONGOC_INSERT_CONTINUE_ON_ERROR;
bson_error_t err;
if(!mongoc_collection_insert(col, flags, b, NULL, &err))
stop(err.message);
return Rf_ScalarLogical(1);
}
// [[Rcpp::internal]]
SEXP rcpp_error_recorder(SEXP e){
SEXP cache = get_rcpp_cache() ;
// error occured
set_error_occured( cache, Rf_ScalarLogical(TRUE) ) ;
// current error
set_current_error(cache, e ) ;
return R_NilValue ;
}
/** Check if a binary relation is transitive
*
* @param x square logical matrix
* @return logical scalar
*
* @version 0.2 (Marek Gagolewski)
*/
SEXP rel_is_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);
for (R_len_t i=0; i<n; ++i) {
for (R_len_t j=0; j<n; ++j) {
if (i == j) continue; // don't care
if (xp[i+j*n] == NA_LOGICAL)
return Rf_ScalarLogical(NA_LOGICAL); // this could be done better
if (!xp[i+j*n]) continue; // nothing more to check
for (R_len_t k=0; k<n; ++k) {
if (xp[i+k*n] == NA_LOGICAL || xp[j+k*n] == NA_LOGICAL)
return Rf_ScalarLogical(NA_LOGICAL); // this could be done better
if (xp[j+k*n] && !xp[i+k*n])
return Rf_ScalarLogical(FALSE);
}
}
}
return Rf_ScalarLogical(TRUE);
}
// [[Rcpp::register]]
SEXP reset_current_error(){
SEXP cache = get_rcpp_cache() ;
// error occured
set_error_occured( cache, Rf_ScalarLogical(FALSE) ) ;
// current error
set_current_error( cache, R_NilValue ) ;
// stack trace
SET_VECTOR_ELT( cache, 3, R_NilValue ) ;
return R_NilValue ;
}
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 ;
}
SEXP R_mongo_collection_create_index(SEXP ptr_col, SEXP ptr_bson) {
mongoc_collection_t *col = r2col(ptr_col);
bson_t *keys = r2bson(ptr_bson);
const char * collection_name = mongoc_collection_get_name(col);
char * index_name = mongoc_collection_keys_to_index_string (keys);
bson_error_t err;
//From: https://s3.amazonaws.com/mciuploads/mongo-c-driver/docs/latest/create-indexes.html
bson_t * command = BCON_NEW ("createIndexes", BCON_UTF8 (collection_name), "indexes",
"[", "{", "key", BCON_DOCUMENT (keys), "name", BCON_UTF8 (index_name), "}", "]");
if(!mongoc_collection_write_command_with_opts(col, command, NULL, NULL, &err))
stop(err.message);
return Rf_ScalarLogical(1);
}
SEXP init_Rcpp_cache(){
SEXP getNamespaceSym = Rf_install("getNamespace"); // cannot be gc()'ed once in symbol table
SEXP RCPP = PROTECT( Rf_eval(Rf_lang2( getNamespaceSym, Rf_mkString("Rcpp") ), R_GlobalEnv) ) ;
SEXP cache = PROTECT( 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) ) ;
SEXP stack = PROTECT(Rf_allocVector(VECSXP, RCPP_PROTECT_STACK_INITIAL_SIZE)) ;
// we use true length to store "top"
SET_TRUELENGTH(stack, -1 ) ;
SET_VECTOR_ELT( cache, RCPP_PROTECTION_STACK_INDEX, stack ) ;
Rf_defineVar( Rf_install(".rcpp_cache"), cache, RCPP );
UNPROTECT(3) ;
return cache ;
}
SEXP extract_impl(SEXP x, SEXP index, SEXP missing) {
if (!Rf_isVector(x)) {
Rf_errorcall(R_NilValue, "`x` must be a vector (not a %s)",
Rf_type2char(TYPEOF(x)));
}
if (TYPEOF(index) != VECSXP) {
Rf_errorcall(R_NilValue, "`index` must be a vector (not a %s)",
Rf_type2char(TYPEOF(index)));
}
int n = Rf_length(index);
for (int i = 0; i < n; ++i) {
SEXP index_i = VECTOR_ELT(index, i);
int offset = find_offset(x, index_i, i);
if (offset < 0)
return missing;
switch(TYPEOF(x)) {
case NILSXP: return missing;
case LGLSXP: x = Rf_ScalarLogical(LOGICAL(x)[offset]); break;
case INTSXP: x = Rf_ScalarInteger(INTEGER(x)[offset]); break;
case REALSXP: x = Rf_ScalarReal(REAL(x)[offset]); break;
case STRSXP: x = Rf_ScalarString(STRING_ELT(x, offset)); break;
case VECSXP: x = VECTOR_ELT(x, offset); break;
default:
Rf_errorcall(R_NilValue,
"Don't know how to index object of type %s at level %i",
Rf_type2char(TYPEOF(x)), i + 1
);
}
}
return x;
}
// adapted from https://github.com/armgong/RJulia/blob/master/src/R_Julia.c
SEXP jr_scalar(jl_value_t *tt)
{
SEXP ans = R_NilValue;
double z;
// float64, int64, int32 are most common, so put them in the front
if (jl_is_float64(tt))
{
PROTECT(ans = Rf_ScalarReal(jl_unbox_float64(tt)));
UNPROTECT(1);
}
else if (jl_is_int32(tt))
{
PROTECT(ans = Rf_ScalarInteger(jl_unbox_int32(tt)));
UNPROTECT(1);
}
else if (jl_is_int64(tt))
{
z = (double)jl_unbox_int64(tt);
if (in_int32_range(z))
PROTECT(ans = Rf_ScalarInteger((int32_t)jl_unbox_int64(tt)));
else
PROTECT(ans = Rf_ScalarReal(z));
UNPROTECT(1);
}
else if (jl_is_bool(tt))
{
PROTECT(ans = Rf_ScalarLogical(jl_unbox_bool(tt)));
UNPROTECT(1);
}
else if (jl_is_int8(tt))
{
PROTECT(ans = Rf_ScalarInteger(jl_unbox_int8(tt)));
UNPROTECT(1);
}
else if (jl_is_uint8(tt))
{
PROTECT(ans = Rf_ScalarInteger(jl_unbox_uint8(tt)));
UNPROTECT(1);
}
else if (jl_is_int16(tt))
{
PROTECT(ans = Rf_ScalarInteger(jl_unbox_int16(tt)));
UNPROTECT(1);
}
else if (jl_is_uint16(tt))
{
PROTECT(ans = Rf_ScalarInteger(jl_unbox_uint16(tt)));
UNPROTECT(1);
}
else if (jl_is_uint32(tt))
{
z = (double)jl_unbox_uint32(tt);
if (in_int32_range(z))
PROTECT(ans = Rf_ScalarInteger((int32_t)jl_unbox_uint32(tt)));
else
PROTECT(ans = Rf_ScalarReal(z));
UNPROTECT(1);
}
else if (jl_is_uint64(tt))
{
z = (double)jl_unbox_int64(tt);
if (in_int32_range(z))
PROTECT(ans = Rf_ScalarInteger((int32_t)jl_unbox_uint64(tt)));
else
PROTECT(ans = Rf_ScalarReal(z));
UNPROTECT(1);
}
else if (jl_is_float32(tt))
{
PROTECT(ans = Rf_ScalarReal(jl_unbox_float32(tt)));
UNPROTECT(1);
}
else if (jl_is_utf8_string(tt))
{
PROTECT(ans = Rf_allocVector(STRSXP, 1));
SET_STRING_ELT(ans, 0, Rf_mkCharCE(jl_string_data(tt), CE_UTF8));
UNPROTECT(1);
}
else if (jl_is_ascii_string(tt))
{
PROTECT(ans = Rf_ScalarString(Rf_mkChar(jl_string_data(tt))));
UNPROTECT(1);
}
return ans;
}
SEXP flatten_impl(SEXP x) {
if (TYPEOF(x) != VECSXP) {
stop_bad_type(x, "a list", NULL, ".x");
}
int m = Rf_length(x);
// Determine output size and check type
int n = 0;
int has_names = 0;
SEXP x_names = PROTECT(Rf_getAttrib(x, R_NamesSymbol));
for (int j = 0; j < m; ++j) {
SEXP x_j = VECTOR_ELT(x, j);
if (!is_vector(x_j) && x_j != R_NilValue) {
stop_bad_element_type(x_j, j + 1, "a vector", NULL, ".x");
}
n += Rf_length(x_j);
if (!has_names) {
if (!Rf_isNull(Rf_getAttrib(x_j, R_NamesSymbol))) {
// Sub-element is named
has_names = 1;
} else if (Rf_length(x_j) == 1 && !Rf_isNull(x_names)) {
// Element is a "scalar" and has name in parent
SEXP name = STRING_ELT(x_names, j);
if (name != NA_STRING && strcmp(CHAR(name), "") != 0)
has_names = 1;
}
}
}
SEXP out = PROTECT(Rf_allocVector(VECSXP, n));
SEXP names = PROTECT(Rf_allocVector(STRSXP, n));
if (has_names)
Rf_setAttrib(out, R_NamesSymbol, names);
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) {
switch(TYPEOF(x_j)) {
case LGLSXP: SET_VECTOR_ELT(out, i, Rf_ScalarLogical(LOGICAL(x_j)[k])); break;
case INTSXP: SET_VECTOR_ELT(out, i, Rf_ScalarInteger(INTEGER(x_j)[k])); break;
case REALSXP: SET_VECTOR_ELT(out, i, Rf_ScalarReal(REAL(x_j)[k])); break;
case CPLXSXP: SET_VECTOR_ELT(out, i, Rf_ScalarComplex(COMPLEX(x_j)[k])); break;
case STRSXP: SET_VECTOR_ELT(out, i, Rf_ScalarString(STRING_ELT(x_j, k))); break;
case RAWSXP: SET_VECTOR_ELT(out, i, Rf_ScalarRaw(RAW(x_j)[k])); break;
case VECSXP: SET_VECTOR_ELT(out, i, VECTOR_ELT(x_j, k)); break;
default:
Rf_error("Internal error: `flatten_impl()` should have failed earlier");
}
if (has_names) {
if (has_names_j) {
SET_STRING_ELT(names, i, has_names_j ? STRING_ELT(names_j, k) : Rf_mkChar(""));
} else if (n_j == 1) {
SET_STRING_ELT(names, i, !Rf_isNull(x_names) ? STRING_ELT(x_names, j) : Rf_mkChar(""));
}
}
if (i % 1024 == 0)
R_CheckUserInterrupt();
}
UNPROTECT(1);
}
UNPROTECT(3);
return out;
}
/** Fetch information on an encoding
*
* @param enc either NULL or "" for default encoding,
* or one string with encoding name
* @return R list object with many components (see R doc for details)
*
* @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_info(SEXP enc)
{
const char* selected_enc = stri__prepare_arg_enc(enc, "enc", true/*default ok*/); /* this is R_alloc'ed */
STRI__ERROR_HANDLER_BEGIN(0)
StriUcnv uconv_obj(selected_enc);
//uconv_obj.setCallBackSubstitute(); // restore default callbacks (no warning)
UConverter* uconv = uconv_obj.getConverter(false);
UErrorCode status = U_ZERO_ERROR;
// get the list of available standards
vector<const char*> standards = StriUcnv::getStandards();
R_len_t standards_n = (R_len_t)standards.size();
// alloc output list
SEXP vals;
SEXP names;
const int nval = standards_n+2+5;
STRI__PROTECT(names = Rf_allocVector(STRSXP, nval));
SET_STRING_ELT(names, 0, Rf_mkChar("Name.friendly"));
SET_STRING_ELT(names, 1, Rf_mkChar("Name.ICU"));
for (R_len_t i=0; i<standards_n; ++i) {
if (standards[i])
SET_STRING_ELT(names, i+2, Rf_mkChar((string("Name.")+standards[i]).c_str()));
}
SET_STRING_ELT(names, nval-5, Rf_mkChar("ASCII.subset"));
SET_STRING_ELT(names, nval-4, Rf_mkChar("Unicode.1to1"));
SET_STRING_ELT(names, nval-3, Rf_mkChar("CharSize.8bit"));
SET_STRING_ELT(names, nval-2, Rf_mkChar("CharSize.min"));
SET_STRING_ELT(names, nval-1, Rf_mkChar("CharSize.max"));
STRI__PROTECT(vals = Rf_allocVector(VECSXP, nval));
// get canonical (ICU) name
status = U_ZERO_ERROR;
const char* canname = ucnv_getName(uconv, &status);
if (U_FAILURE(status) || !canname) {
SET_VECTOR_ELT(vals, 1, Rf_ScalarString(NA_STRING));
Rf_warning(MSG__ENC_ERROR_GETNAME);
}
else {
SET_VECTOR_ELT(vals, 1, stri__make_character_vector_char_ptr(1, canname));
// friendly name
const char* frname = StriUcnv::getFriendlyName(canname);
if (frname) SET_VECTOR_ELT(vals, 0, stri__make_character_vector_char_ptr(1, frname));
else SET_VECTOR_ELT(vals, 0, Rf_ScalarString(NA_STRING));
// has ASCII as its subset?
SET_VECTOR_ELT(vals, nval-5, Rf_ScalarLogical((int)uconv_obj.hasASCIIsubset()));
// min,max character size, is 8bit?
int mincharsize = (int)ucnv_getMinCharSize(uconv);
int maxcharsize = (int)ucnv_getMaxCharSize(uconv);
int is8bit = (mincharsize==1 && maxcharsize == 1);
SET_VECTOR_ELT(vals, nval-3, Rf_ScalarLogical(is8bit));
SET_VECTOR_ELT(vals, nval-2, Rf_ScalarInteger(mincharsize));
SET_VECTOR_ELT(vals, nval-1, Rf_ScalarInteger(maxcharsize));
// is there a one-to-one correspondence with Unicode?
if (!is8bit)
SET_VECTOR_ELT(vals, nval-4, Rf_ScalarLogical(NA_LOGICAL));
else
SET_VECTOR_ELT(vals, nval-4, Rf_ScalarLogical((int)uconv_obj.is1to1Unicode()));
// other standard names
for (R_len_t i=0; i<standards_n; ++i) {
if (!standards[i]) continue;
status = U_ZERO_ERROR;
const char* stdname = ucnv_getStandardName(canname, standards[i], &status);
if (U_FAILURE(status) || !stdname)
SET_VECTOR_ELT(vals, i+2, Rf_ScalarString(NA_STRING));
else
SET_VECTOR_ELT(vals, i+2, stri__make_character_vector_char_ptr(1, stdname));
}
}
Rf_setAttrib(vals, R_NamesSymbol, names);
STRI__UNPROTECT_ALL
return vals;
STRI__ERROR_HANDLER_END({/* no special action on error */})
}
SEXP enableMxLog()
{
mxLogEnabled = true;
return Rf_ScalarLogical(1);
}
/** internal function - replace multiple substrings in a single string
* can raise Rf_error
*
* @version 1.3.2 (Marek Gagolewski, 2019-02-23)
*
* @version 1.4.3 (Marek Gagolewski, 2019-03-12)
* #346: na_omit for `value`
*/
SEXP stri__sub_replacement_all_single(SEXP curs,
SEXP from, SEXP to, SEXP length, bool omit_na_1, SEXP value)
{
// curs is a CHARSXP in UTF-8
PROTECT(value = stri_enc_toutf8(value,
Rf_ScalarLogical(FALSE), Rf_ScalarLogical(FALSE)));
R_len_t value_len = LENGTH(value);
R_len_t from_len = 0; // see below
R_len_t to_len = 0; // see below
R_len_t length_len = 0; // see below
int* from_tab = 0; // see below
int* to_tab = 0; // see below
int* length_tab = 0; // see below
R_len_t sub_protected = 1+ /* how many objects to PROTECT on ret? */
stri__sub_prepare_from_to_length(from, to, length,
from_len, to_len, length_len, from_tab, to_tab, length_tab);
R_len_t vectorize_len = stri__recycling_rule(true, 2, // does not care about value_len
from_len, (to_len>length_len)?to_len:length_len);
if (vectorize_len <= 0) { // "nothing" is being replaced -> return the input as-is
UNPROTECT(sub_protected);
return curs;
}
if (value_len <= 0) { // things are supposed to be replaced with "nothing"...
UNPROTECT(sub_protected);
Rf_warning(MSG__REPLACEMENT_ZERO);
return NA_STRING;
}
if (vectorize_len % value_len != 0)
Rf_warning(MSG__WARN_RECYCLING_RULE2);
const char* curs_s = CHAR(curs); // already in UTF-8
R_len_t curs_n = LENGTH(curs);
// first check for NAs....
if (!omit_na_1) {
for (R_len_t i=0; i<vectorize_len; ++i) {
R_len_t cur_from = from_tab[i % from_len];
R_len_t cur_to = (to_tab)?to_tab[i % to_len]:length_tab[i % length_len];
if (cur_from == NA_INTEGER || cur_to == NA_INTEGER) {
UNPROTECT(sub_protected);
if (omit_na_1) return curs;
else return NA_STRING;
}
}
for (R_len_t i=0; i<vectorize_len; ++i) {
if (STRING_ELT(value, i%value_len) == NA_STRING) {
UNPROTECT(sub_protected);
return NA_STRING;
}
}
}
// get the number of code points in curs, if required (for negative indexes)
R_len_t curs_m = -1;
if (IS_ASCII(curs)) curs_m = curs_n;
else { // is UTF-8
curs_m = 0; // code points count
R_len_t j = 0; // byte pos
while (j < curs_n) {
U8_FWD_1_UNSAFE(curs_s, j);
++curs_m;
}
}
STRI__ERROR_HANDLER_BEGIN(sub_protected)
std::vector<char> buf; // convenience >> speed
R_len_t buf_size;
R_len_t last_pos = 0;
R_len_t byte_pos = 0, byte_pos_last;
for (R_len_t i=0; i<vectorize_len; ++i) {
R_len_t cur_from = from_tab[i % from_len];
R_len_t cur_to = (to_tab)?to_tab[i % to_len]:length_tab[i % length_len];
if (cur_from == NA_INTEGER || cur_to == NA_INTEGER || STRING_ELT(value, i%value_len) == NA_STRING) {
continue;
}
if (cur_from < 0) cur_from = curs_m+cur_from+1;
if (cur_from <= 0) cur_from = 1;
cur_from--; // 1-based -> 0-based index
if (cur_from >= curs_m) cur_from = curs_m;
// cur_from is in [0, curs_m]
if (length_tab) {
if (cur_to < 0) cur_to = 0;
cur_to = cur_from+cur_to;
}
else {
if (cur_to < 0) cur_to = curs_m+cur_to+1;
if (cur_to < cur_from) cur_to = cur_from; // insertion
}
if (cur_to >= curs_m) cur_to = curs_m;
// the chunk to replace is at code points [cur_from, cur_to)
// Rprintf("orig [%d,%d) repl [%d,%d)\n", last_pos, cur_from, cur_from, cur_to);
if (last_pos > cur_from)
throw StriException(MSG__OVERLAPPING_OR_UNSORTED_INDEXES);
// first, copy [last_pos, cur_from)
byte_pos_last = byte_pos;
while (last_pos < cur_from) {
U8_FWD_1_UNSAFE(curs_s, byte_pos);
++last_pos;
}
buf_size = buf.size();
buf.resize(buf_size+byte_pos-byte_pos_last);
memcpy(buf.data()+buf_size, curs_s+byte_pos_last, byte_pos-byte_pos_last);
// then, copy the corresponding replacement string
SEXP value_cur = STRING_ELT(value, i%value_len);
const char* value_s = CHAR(value_cur);
R_len_t value_n = LENGTH(value_cur);
buf_size = buf.size();
buf.resize(buf_size+value_n);
memcpy(buf.data()+buf_size, value_s, value_n);
// lastly, update last_pos
// ---> last_pos = cur_to;
while (last_pos < cur_to) {
U8_FWD_1_UNSAFE(curs_s, byte_pos);
++last_pos;
}
}
// finally, copy [last_pos, curs_m)
// Rprintf("orig [%d,%d)\n", last_pos, curs_m);
buf_size = buf.size();
buf.resize(buf_size+curs_n-byte_pos);
memcpy(buf.data()+buf_size, curs_s+byte_pos, curs_n-byte_pos);
SEXP ret;
STRI__PROTECT(ret = Rf_mkCharLenCE(buf.data(), buf.size(), CE_UTF8));
STRI__UNPROTECT_ALL
return ret;
STRI__ERROR_HANDLER_END(;/* nothing special to be done on error */)
}
SEXP transpose_impl(SEXP x, SEXP names_template) {
if (TYPEOF(x) != VECSXP)
Rf_errorcall(R_NilValue, "`.l` is not a list (%s)", Rf_type2char(TYPEOF(x)));
int n = Rf_length(x);
if (n == 0) {
return Rf_allocVector(VECSXP, 0);
}
int has_template = !Rf_isNull(names_template);
SEXP x1 = VECTOR_ELT(x, 0);
if (!Rf_isVector(x1))
Rf_errorcall(R_NilValue, "Element 1 is not a vector (%s)", Rf_type2char(TYPEOF(x1)));
int m = has_template ? Rf_length(names_template) : Rf_length(x1);
// Create space for output
SEXP out = PROTECT(Rf_allocVector(VECSXP, m));
SEXP names1 = Rf_getAttrib(x, R_NamesSymbol);
for (int j = 0; j < m; ++j) {
SEXP xj = PROTECT(Rf_allocVector(VECSXP, n));
if (!Rf_isNull(names1)) {
Rf_setAttrib(xj, R_NamesSymbol, names1);
}
SET_VECTOR_ELT(out, j, xj);
UNPROTECT(1);
}
SEXP names2 = has_template ? names_template : Rf_getAttrib(x1, R_NamesSymbol);
if (!Rf_isNull(names2)) {
Rf_setAttrib(out, R_NamesSymbol, names2);
}
// Fill output
for (int i = 0; i < n; ++i) {
SEXP xi = VECTOR_ELT(x, i);
if (!Rf_isVector(xi))
Rf_errorcall(R_NilValue, "Element %i is not a vector (%s)", i + 1, Rf_type2char(TYPEOF(x1)));
// find mapping between names and index. Use -1 to indicate not found
SEXP names_i = Rf_getAttrib(xi, R_NamesSymbol);
SEXP index;
if (!Rf_isNull(names2) && !Rf_isNull(names_i)) {
index = PROTECT(Rf_match(names_i, names2, 0));
// Rf_match returns 1-based index; convert to 0-based for C
for (int i = 0; i < m; ++i) {
INTEGER(index)[i] = INTEGER(index)[i] - 1;
}
} else {
index = PROTECT(Rf_allocVector(INTSXP, m));
int mi = Rf_length(xi);
if (m != mi) {
Rf_warningcall(R_NilValue, "Element %i has length %i not %i", i + 1, mi, m);
}
for (int i = 0; i < m; ++i) {
INTEGER(index)[i] = (i < mi) ? i : -1;
}
}
int* pIndex = INTEGER(index);
for (int j = 0; j < m; ++j) {
int pos = pIndex[j];
if (pos == -1)
continue;
switch(TYPEOF(xi)) {
case LGLSXP:
SET_VECTOR_ELT(VECTOR_ELT(out, j), i, Rf_ScalarLogical(LOGICAL(xi)[pos]));
break;
case INTSXP:
SET_VECTOR_ELT(VECTOR_ELT(out, j), i, Rf_ScalarInteger(INTEGER(xi)[pos]));
break;
case REALSXP:
SET_VECTOR_ELT(VECTOR_ELT(out, j), i, Rf_ScalarReal(REAL(xi)[pos]));
break;
case STRSXP:
SET_VECTOR_ELT(VECTOR_ELT(out, j), i, Rf_ScalarString(STRING_ELT(xi, pos)));
break;
case VECSXP:
SET_VECTOR_ELT(VECTOR_ELT(out, j), i, VECTOR_ELT(xi, pos));
break;
default:
Rf_errorcall(R_NilValue, "Unsupported type %s", Rf_type2char(TYPEOF(xi)));
}
}
UNPROTECT(1);
}
UNPROTECT(1);
return out;
}
/** Get localized time zone info
*
* @param tz single string or NULL
* @param locale single string or NULL
* @param display_type single string
* @return list
*
* @version 0.5-1 (Marek Gagolewski, 2014-12-24)
*
* @version 0.5-1 (Marek Gagolewski, 2015-03-01)
* new out: WindowsID, NameDaylight, new in: display_type
*/
SEXP stri_timezone_info(SEXP tz, SEXP locale, SEXP display_type) {
TimeZone* curtz = stri__prepare_arg_timezone(tz, "tz", R_NilValue);
const char* qloc = stri__prepare_arg_locale(locale, "locale", true); /* this is R_alloc'ed */
const char* dtype_str = stri__prepare_arg_string_1_notNA(display_type, "display_type"); /* this is R_alloc'ed */
const char* dtype_opts[] = {
"short", "long", "generic_short", "generic_long", "gmt_short", "gmt_long",
"common", "generic_location",
NULL};
int dtype_cur = stri__match_arg(dtype_str, dtype_opts);
TimeZone::EDisplayType dtype;
switch (dtype_cur) {
case 0: dtype = TimeZone::SHORT; break;
case 1: dtype = TimeZone::LONG; break;
case 2: dtype = TimeZone::SHORT_GENERIC; break;
case 3: dtype = TimeZone::LONG_GENERIC; break;
case 4: dtype = TimeZone::SHORT_GMT; break;
case 5: dtype = TimeZone::LONG_GMT; break;
case 6: dtype = TimeZone::SHORT_COMMONLY_USED; break;
case 7: dtype = TimeZone::GENERIC_LOCATION; break;
default: Rf_error(MSG__INCORRECT_MATCH_OPTION, "display_type"); break;
}
const R_len_t infosize = 6;
SEXP vals;
PROTECT(vals = Rf_allocVector(VECSXP, infosize));
for (int i=0; i<infosize; ++i)
SET_VECTOR_ELT(vals, i, R_NilValue);
R_len_t curidx = -1;
++curidx;
UnicodeString val_ID;
curtz->getID(val_ID);
SET_VECTOR_ELT(vals, curidx, stri__make_character_vector_UnicodeString_ptr(1, &val_ID));
++curidx;
UnicodeString val_name;
curtz->getDisplayName(false, dtype, Locale::createFromName(qloc), val_name);
SET_VECTOR_ELT(vals, curidx, stri__make_character_vector_UnicodeString_ptr(1, &val_name));
++curidx;
if ((bool)curtz->useDaylightTime()) {
UnicodeString val_name2;
curtz->getDisplayName(true, dtype, Locale::createFromName(qloc), val_name2);
SET_VECTOR_ELT(vals, curidx, stri__make_character_vector_UnicodeString_ptr(1, &val_name2));
}
else
SET_VECTOR_ELT(vals, curidx, Rf_ScalarString(NA_STRING));
++curidx;
UnicodeString val_windows;
UErrorCode status = U_ZERO_ERROR;
#if U_ICU_VERSION_MAJOR_NUM>=52
TimeZone::getWindowsID(val_ID, val_windows, status); // Stable since ICU 52
#endif
if (U_SUCCESS(status) && val_windows.length() > 0)
SET_VECTOR_ELT(vals, curidx, stri__make_character_vector_UnicodeString_ptr(1, &val_windows));
else
SET_VECTOR_ELT(vals, curidx, Rf_ScalarString(NA_STRING));
++curidx;
SET_VECTOR_ELT(vals, curidx, Rf_ScalarReal(curtz->getRawOffset()/1000.0/3600.0));
++curidx;
SET_VECTOR_ELT(vals, curidx, Rf_ScalarLogical((bool)curtz->useDaylightTime()));
delete curtz;
stri__set_names(vals, infosize, "ID", "Name", "Name.Daylight", "Name.Windows", "RawOffset", "UsesDaylightTime");
UNPROTECT(1);
return vals;
}
* new retval field: ICU.UTF8
*/
SEXP stri_info()
{
STRI__ERROR_HANDLER_BEGIN(0)
const R_len_t infosize = 7;
SEXP vals;
STRI__PROTECT(vals = Rf_allocVector(VECSXP, infosize));
SET_VECTOR_ELT(vals, 0, Rf_mkString(U_UNICODE_VERSION));
SET_VECTOR_ELT(vals, 1, Rf_mkString(U_ICU_VERSION));
SET_VECTOR_ELT(vals, 2, stri_locale_info(R_NilValue)); // may call Rf_error
SET_VECTOR_ELT(vals, 3,
stri__make_character_vector_char_ptr(2, "UTF-8", "UTF-16")); // fixed strings
SET_VECTOR_ELT(vals, 4, stri_enc_info(R_NilValue)); // may call Rf_error
SET_VECTOR_ELT(vals, 5, Rf_ScalarLogical(STRI_ICU_FOUND));
SET_VECTOR_ELT(vals, 6, Rf_ScalarLogical(0));
#ifdef U_CHARSET_IS_UTF8
#if U_CHARSET_IS_UTF8
SET_VECTOR_ELT(vals, 6, Rf_ScalarLogical(1));
#endif
#endif
stri__set_names(vals, infosize,
"Unicode.version", "ICU.version", "Locale",
"Charset.internal", "Charset.native", "ICU.system", "ICU.UTF8");
STRI__UNPROTECT_ALL
return vals;
STRI__ERROR_HANDLER_END(;/* nothing special to be done on error */)
/**
* Replace multiple substrings
*
*
* @param str character vector
* @param from integer vector (possibly with negative indices)
* @param to integer vector (possibly with negative indices) or NULL
* @param length integer vector or NULL
* @param omit_na logical scalar
* @param value character vector replacement
* @return character vector
*
* @version 1.3.2 (Marek Gagolewski, 2019-02-22)
* #30: new function
*
*
* @version 1.4.3 (Marek Gagolewski, 2019-03-12)
* #346: na_omit for `value`
*/
SEXP stri_sub_replacement_all(SEXP str, SEXP from, SEXP to, SEXP length, SEXP omit_na, SEXP value)
{
//PROTECT(str = stri_prepare_arg_string(str, "str"));
PROTECT(str = stri_enc_toutf8(str, Rf_ScalarLogical(FALSE), Rf_ScalarLogical(FALSE)));
PROTECT(from = stri_prepare_arg_list(from, "from"));
PROTECT(to = stri_prepare_arg_list(to, "to"));
PROTECT(length = stri_prepare_arg_list(length, "length"));
PROTECT(value = stri_prepare_arg_list(value, "value"));
bool omit_na_1 = stri__prepare_arg_logical_1_notNA(omit_na, "omit_na");
R_len_t str_len = LENGTH(str);
R_len_t from_len = LENGTH(from);
R_len_t value_len = LENGTH(value);
R_len_t vectorize_len;
if (!isNull(to))
vectorize_len = stri__recycling_rule(true, 4,
str_len, from_len, value_len, LENGTH(to));
else if (!isNull(length))
vectorize_len = stri__recycling_rule(true, 4,
str_len, from_len, value_len, LENGTH(length));
else
vectorize_len = stri__recycling_rule(true, 3, str_len, from_len, value_len);
if (vectorize_len <= 0) {
UNPROTECT(5);
return Rf_allocVector(STRSXP, 0);
}
// no STRI__ERROR_HANDLER_BEGIN block ---- below we can longjmp with Rf_error...
SEXP ret, curs, tmp;
PROTECT(ret = Rf_allocVector(STRSXP, vectorize_len)); // 6
for (R_len_t i = 0; i<vectorize_len; ++i)
{
curs = STRING_ELT(str, i%str_len);
if (curs == NA_STRING) {
SET_STRING_ELT(ret, i, NA_STRING);
continue;
}
if (!isNull(to)) {
PROTECT(tmp = stri__sub_replacement_all_single(curs,
VECTOR_ELT(from, i%from_len),
VECTOR_ELT(to, i%LENGTH(to)), R_NilValue,
omit_na_1, VECTOR_ELT(value, i%value_len)));
}
else if (!isNull(length)) {
PROTECT(tmp = stri__sub_replacement_all_single(curs,
VECTOR_ELT(from, i%from_len),
R_NilValue, VECTOR_ELT(length, i%LENGTH(length)),
omit_na_1, VECTOR_ELT(value, i%value_len)));
}
else {
PROTECT(tmp = stri__sub_replacement_all_single(curs,
VECTOR_ELT(from, i%from_len),
R_NilValue, R_NilValue,
omit_na_1, VECTOR_ELT(value, i%value_len)));
}
SET_STRING_ELT(ret, i, tmp);
UNPROTECT(1); //tmp
}
UNPROTECT(6);
return ret;
}
SEXP R_any_special(SEXP x) {
return Rf_ScalarLogical(any_special(x));
}
