/* Origin: SEXP attribute_hidden do_stop(). */
SEXP api_R_stop(SEXP args){
SEXP call, c_call;
args = CDR(args); /* get caller name */
call = CAR(args);
args = CDR(args);
if(asLogical(CAR(args))){ /* find context -> "... in: ..:" */
c_call = call;
} else{
c_call = R_NilValue;
}
args = CDR(args);
if(CAR(args) != R_NilValue){ /* message */
SETCAR(args, coerceVector(CAR(args), STRSXP));
if(!isValidString(CAR(args))){
Rf_errorcall(c_call,
" [invalid string in comm.stop(.)]\n");
}
Rf_errorcall(c_call, "%s",
translateChar(STRING_ELT(CAR(args), 0)));
} else{
Rf_errorcall(c_call, "\n");
}
return c_call;
} /* End of api_R_stop(). */
int find_offset(SEXP x, SEXP index, int i) {
if (!Rf_isVector(index) || Rf_length(index) != 1)
Rf_errorcall(R_NilValue, "Index %i is not a length 1 vector", i + 1);
int n = Rf_length(x);
if (TYPEOF(index) == INTSXP) {
int val = INTEGER(index)[0];
if (val == NA_INTEGER)
return -1;
val--;
if (val < 0 || val >= n)
return -1;
return val;
} if (TYPEOF(index) == REALSXP) {
double val = REAL(index)[0];
if (!R_finite(val))
return -1;
val--;
if (val < 0 || val >= n)
return -1;
return val;
} else if (TYPEOF(index) == STRSXP) {
SEXP names = Rf_getAttrib(x, R_NamesSymbol);
if (names == R_NilValue) // vector doesn't have names
return -1;
if (STRING_ELT(index, 0) == NA_STRING)
return -1;
const char* val = Rf_translateCharUTF8(STRING_ELT(index, 0));
if (val[0] == '\0') // "" matches nothing
return -1;
for (int j = 0; j < Rf_length(names); ++j) {
if (STRING_ELT(names, j) == NA_STRING)
continue;
const char* names_j = Rf_translateCharUTF8(STRING_ELT(names, j));
if (strcmp(names_j, val) == 0)
return j;
}
return -1;
} else {
Rf_errorcall(R_NilValue,
"Don't know how to index with object of type %s at level %i",
Rf_type2char(TYPEOF(index)), i + 1
);
}
}
void StackChecker::handleStackSpaceExceeded()
{
// We'll need to use the remaining stack space for error recovery,
// so temporarily disable stack checking.
DisableStackCheckingScope no_stack_checking;
// Do not translate this, to save stack space.
Rf_errorcall(R_NilValue, "C stack usage is too close to the limit");
}
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;
}
SEXP R_mongo_collection_insert_page(SEXP ptr_col, SEXP json_vec, SEXP stop_on_error){
if(!Rf_isString(json_vec) || !Rf_length(json_vec))
stop("json_vec must be character string of at least length 1");
//ordered means serial execution
bool ordered = Rf_asLogical(stop_on_error);
//create bulk operation
bson_error_t err;
bson_t *b;
bson_t reply;
mongoc_bulk_operation_t *bulk = mongoc_collection_create_bulk_operation_with_opts (r2col(ptr_col), NULL);
for(int i = 0; i < Rf_length(json_vec); i++){
b = bson_new_from_json ((uint8_t*) Rf_translateCharUTF8(Rf_asChar(STRING_ELT(json_vec, i))), -1, &err);
if(!b){
mongoc_bulk_operation_destroy (bulk);
stop(err.message);
}
mongoc_bulk_operation_insert(bulk, b);
bson_destroy (b);
b = NULL;
}
//execute bulk operation
bool success = mongoc_bulk_operation_execute (bulk, &reply, &err);
mongoc_bulk_operation_destroy (bulk);
//check for errors
if(!success){
if(ordered){
Rf_errorcall(R_NilValue, err.message);
} else {
Rf_warningcall(R_NilValue, "Not all inserts were successful: %s\n", err.message);
}
}
//get output
SEXP out = PROTECT(bson2list(&reply));
bson_destroy (&reply);
UNPROTECT(1);
return out;
}
SEXP R_parse(SEXP x, SEXP bigint_as_char) {
/* get data from R */
const char* json = translateCharUTF8(asChar(x));
const int bigint = asLogical(bigint_as_char);
/* ignore BOM as suggested by RFC */
if(json[0] == '\xEF' && json[1] == '\xBB' && json[2] == '\xBF'){
warningcall(R_NilValue, "JSON string contains (illegal) UTF8 byte-order-mark!");
json = json + 3;
}
/* parse json */
char errbuf[1024];
yajl_val node = yajl_tree_parse(json, errbuf, sizeof(errbuf));
/* parser error */
if (!node) {
Rf_errorcall(R_NilValue, errbuf);
}
SEXP out = ParseValue(node, bigint);
yajl_tree_free(node);
return(out);
}
void StackChecker::handleStackDepthExceeded()
{
DisableStackCheckingScope no_stack_checking;
Rf_errorcall(nullptr, _("evaluation nested too deeply: "
"infinite recursion / options(expressions=)?"));
}
void errorCall(SEXP call, const std::string& message)
{
Rf_errorcall(call, message.c_str());
}
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;
}
