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 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 ;
}
SEXP
getAlternatives(tesseract::ResultIterator* ri, const char *word, float conf)
{
tesseract::ChoiceIterator ci_r(*ri);
int nels = 2;
while(ci_r.Next())
nels++;
SEXP ans, names;
PROTECT(ans = NEW_NUMERIC(nels));
PROTECT(names = NEW_CHARACTER(nels));
int i = 0;
SET_STRING_ELT(names, 0, Rf_mkChar(word));
REAL(ans)[0] = conf;
tesseract::ChoiceIterator ci(*ri);
for(i = 1; i < nels ; i++, ci.Next()) {
const char* choice = ci.GetUTF8Text();
conf = ci.Confidence();
if(choice)
SET_STRING_ELT(names, i, Rf_mkChar(choice));
REAL(ans)[i] = conf;
// delete [] choice;
}
SET_NAMES(ans, names);
UNPROTECT(2);
return(ans);
}
// 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
}
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;
}
/** Set POSIXct class on a given object
*
* @param x R object
*
* @version 0.5-1 (Marek Gagolewski, 2014-12-29)
*/
void stri__set_class_POSIXct(SEXP x) {
SEXP cl;
PROTECT(cl = Rf_allocVector(STRSXP, 2));
// SET_STRING_ELT(cl, 0, Rf_mkChar("POSIXst"));
SET_STRING_ELT(cl, 0, Rf_mkChar("POSIXct"));
SET_STRING_ELT(cl, 1, Rf_mkChar("POSIXt"));
Rf_setAttrib(x, R_ClassSymbol, cl);
UNPROTECT(1);
}
SEXP get_exception_classes( const std::string& ex_class) {
SEXP res = PROTECT( 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" ) ) ;
UNPROTECT(1) ;
return res;
}
PosixBackend(const TSDIM rows, const TSDIM cols) : BackendBase(Rallocator<TDATA>::getType(), rows, cols) {
// create dates
SEXP R_dates = PROTECT(Rallocator<TDATE>::Vector(rows));
// create and add dates class to dates object
SEXP r_dates_class = PROTECT(Rf_allocVector(STRSXP, 2));
SET_STRING_ELT(r_dates_class, 0, Rf_mkChar("POSIXct"));
SET_STRING_ELT(r_dates_class, 1, Rf_mkChar("POSIXt"));
Rf_classgets(R_dates, r_dates_class);
// attach dates to Robject
Rf_setAttrib(Robject, Rf_install("index"), R_dates);
UNPROTECT(2); // R_dates, r_dates_class
}
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 jr_data_frame(jl_value_t *tt)
{
SEXP ans = R_NilValue;
SEXP rnames, d;
jl_array_t *names = (jl_array_t *) jl_get_nth_field(jl_get_nth_field(tt, 1), 1);
jl_array_t *columns = (jl_array_t *) jl_get_nth_field(tt, 0);
JL_GC_PUSH2(&names, &columns);
size_t n = jl_array_len(jl_get_nth_field(jl_arrayref(columns, 0), 0));
size_t m = jl_array_len(columns);
PROTECT(ans = Rf_allocVector(VECSXP, m));
PROTECT(rnames = Rf_allocVector(STRSXP, m));
for(size_t i=0; i<m; i++)
{
SET_VECTOR_ELT(ans, i, jr_data_array((jl_value_t *) jl_arrayref(columns, i)));
SET_STRING_ELT(rnames, i, Rf_mkChar(((jl_sym_t *) jl_arrayref(names, i))->name));
}
Rf_setAttrib(ans, R_NamesSymbol, rnames);
Rf_setAttrib(ans, R_ClassSymbol, Rf_mkString("data.frame"));
d = PROTECT(Rf_allocVector(INTSXP ,n));
for(size_t i=0; i<n; i++){
INTEGER(d)[i] = i+1;
}
Rf_setAttrib(ans, R_RowNamesSymbol, d);
UNPROTECT(3);
JL_GC_POP();
return ans;
}
SEXP jr_dict(jl_value_t *tt)
{
SEXP ans = R_NilValue;
SEXP rnames;
jl_function_t *str = jl_get_function(jl_base_module, "string");
jl_function_t *getindex = jl_get_function(jl_base_module, "getindex");
jl_array_t *keys = (jl_array_t *) jl_call1(
jl_get_function(jl_base_module, "collect"),
jl_call1(jl_get_function(jl_base_module, "keys"), tt)
);
size_t m = jl_array_len(keys);
PROTECT(rnames = Rf_allocVector(STRSXP, m));
PROTECT(ans = Rf_allocVector(VECSXP, m));
jl_value_t *key, *value;
for(size_t i=0; i<m; i++)
{
key = jl_arrayref(keys, i);
value = jl_call2(getindex, tt, key);
SET_VECTOR_ELT(ans, i, jr_cast(value));
key = jl_call1(str, key);
SET_STRING_ELT(rnames, i, Rf_mkChar(jl_string_data(key)));
}
Rf_setAttrib(ans, R_NamesSymbol, rnames);
UNPROTECT(2);
return ans;
}
static void rc_validate_connection(rconn_t *c, int optional) {
if (!c->rc && (c->flags & RCF_RECONNECT)) {
struct timeval tv;
tv.tv_sec = (int) c->timeout;
tv.tv_usec = (c->timeout - (double)tv.tv_sec) * 1000000.0;
if (c->port < 1)
c->rc = redisConnectUnixWithTimeout(c->host, tv);
else
c->rc = redisConnectWithTimeout(c->host, c->port, tv);
if (!c->rc) {
if (optional) return;
Rf_error("disconnected connection and re-connect to redis failed (NULL context)");
}
if (c->rc->err){
SEXP es = Rf_mkChar(c->rc->errstr);
redisFree(c->rc);
c->rc = 0;
if (optional) return;
Rf_error("disconnected connection and re-connect to redis failed: %s", CHAR(es));
}
redisSetTimeout(c->rc, tv);
/* re-connect succeeded */
}
if (!c->rc && !optional)
Rf_error("disconnected redis connection");
}
/* issuue one command with one key paratemer and return the result */
SEXP cr_cmd(SEXP sc, SEXP sArgs) {
rconn_t *c;
const char **argv = argbuf;
int n, i;
redisReply *reply;
SEXP res;
if (!Rf_inherits(sc, "redisConnection")) Rf_error("invalid connection");
c = (rconn_t*) EXTPTR_PTR(sc);
if (!c) Rf_error("invalid connection (NULL)");
rc_validate_connection(c, 0);
if (TYPEOF(sArgs) != STRSXP || LENGTH(sArgs) < 1)
Rf_error("invalid command - must be a string");
n = LENGTH(sArgs);
if (n + 1 > NARGBUF) {
argv = malloc(sizeof(const char*) * (n + 2));
if (!argv)
Rf_error("out of memory");
}
for (i = 0; i < n; i++)
argv[i] = CHAR(STRING_ELT(sArgs, i));
/* we use strings only, so no need to supply argvlen */
reply = redisCommandArgv(c->rc, n, argv, 0);
if (!reply && (c->flags & RCF_RETRY)) {
SEXP es = Rf_mkChar(c->rc->errstr);
rc_close(c);
rc_validate_connection(c, 1);
if (c->rc)
reply = redisCommandArgv(c->rc, 2, argv, 0);
else {
if (argv != argbuf)
free(argv);
Rf_error("%s error: %s and re-connect failed", argv[0], CHAR(es));
}
}
if (argv != argbuf)
free(argv);
if (!reply) {
SEXP es = Rf_mkChar(c->rc->errstr);
rc_close(c);
Rf_error("%s error: %s", argv[0], CHAR(es));
}
/* Rprintf("reply, type=%d\n", reply->type); */
res = rc_reply2R(reply);
freeReplyObject(reply);
return res;
}
SEXP cr_del(SEXP sc, SEXP keys) {
rconn_t *c;
int n, i;
const char **argv = argbuf;
redisReply *reply;
if (!Rf_inherits(sc, "redisConnection")) Rf_error("invalid connection");
c = (rconn_t*) EXTPTR_PTR(sc);
if (!c) Rf_error("invalid connection (NULL)");
rc_validate_connection(c, 0);
if (TYPEOF(keys) != STRSXP)
Rf_error("invalid keys");
n = LENGTH(keys);
if (n + 1 > NARGBUF) {
argv = malloc(sizeof(const char*) * (n + 2));
if (!argv)
Rf_error("out of memory");
}
argv[0] = "DEL";
for (i = 0; i < n; i++)
argv[i + 1] = CHAR(STRING_ELT(keys, i));
/* we use strings only, so no need to supply argvlen */
reply = redisCommandArgv(c->rc, n + 1, argv, 0);
if (!reply && (c->flags & RCF_RETRY)) {
SEXP es = Rf_mkChar(c->rc->errstr);
rc_close(c);
rc_validate_connection(c, 1);
if (c->rc)
reply = redisCommandArgv(c->rc, n + 1, argv, 0);
else {
if (argv != argbuf)
free(argv);
Rf_error("DEL error: %s and re-connect failed", CHAR(es));
}
}
if (argv != argbuf)
free(argv);
if (!reply) {
SEXP es = Rf_mkChar(c->rc->errstr);
rc_close(c);
Rf_error("DEL error: %s", CHAR(es));
}
/* Rprintf("reply, type=%d\n", reply->type); */
freeReplyObject(reply);
return R_NilValue;
}
SEXP audio_drivers_list() {
int n = 0;
SEXP res = Rf_allocVector(VECSXP, 3), sName, sDesc, /* sCopy, */ sCurr, sLN, sRN;
audio_driver_list_t *l = &audio_drivers;
if (!current_driver)
load_default_audio_driver(1);
Rf_protect(res);
if (l->driver) {
while (l) {
n++;
l = l->next;
}
}
sName = Rf_allocVector(STRSXP, n); SET_VECTOR_ELT(res, 0, sName);
sDesc = Rf_allocVector(STRSXP, n); SET_VECTOR_ELT(res, 1, sDesc);
sCurr = Rf_allocVector(LGLSXP, n); SET_VECTOR_ELT(res, 2, sCurr);
/* sCopy = Rf_allocVector(STRSXP, n); SET_VECTOR_ELT(res, 3, sCopy); */
if (n) {
n = 0;
l = &audio_drivers;
while (l) {
const char *s = l->driver->name;
SET_STRING_ELT(sName, n, Rf_mkChar(s ? s : ""));
s = l->driver->descr;
SET_STRING_ELT(sDesc, n, Rf_mkChar(s ? s : ""));
s = l->driver->copyright;
/* SET_STRING_ELT(sCopy, n, Rf_mkChar(s ? s : "")); */
LOGICAL(sCurr)[n] = (l->driver == current_driver) ? 1 : 0;
l = l->next;
n++;
}
}
sLN = Rf_allocVector(STRSXP, 3);
Rf_setAttrib(res, R_NamesSymbol, sLN);
SET_STRING_ELT(sLN, 0, Rf_mkChar("name"));
SET_STRING_ELT(sLN, 1, Rf_mkChar("description"));
SET_STRING_ELT(sLN, 2, Rf_mkChar("current"));
/* SET_STRING_ELT(sLN, 3, Rf_mkChar("author")); */
sRN = Rf_allocVector(INTSXP, 2);
Rf_setAttrib(res, R_RowNamesSymbol, sRN);
INTEGER(sRN)[0] = R_NaInt;
INTEGER(sRN)[1] = -n;
Rf_setAttrib(res, R_ClassSymbol, Rf_mkString("data.frame"));
Rf_unprotect(1);
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 REmbed::parseEval(QString line, SEXP & ans) {
ParseStatus status;
SEXP cmdSexp, cmdexpr = R_NilValue;
int i, errorOccurred;
program << line;
PROTECT(cmdSexp = Rf_allocVector(STRSXP, 1));
SET_STRING_ELT(cmdSexp, 0, Rf_mkChar(program.join(" ").toStdString().c_str()));
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), R_GlobalEnv, &errorOccurred);
if (errorOccurred) {
if (verbose) Rf_warning("%s: Error in evaluating R code (%d)\n", name, status);
UNPROTECT(2);
program.clear();
return 1;
}
if (verbose) {
Rf_PrintValue(ans);
}
}
program.clear();
break;
case PARSE_INCOMPLETE:
// need to read another line
break;
case PARSE_NULL:
if (verbose) Rf_warning("%s: ParseStatus is null (%d)\n", name, status);
UNPROTECT(2);
program.clear();
return 1;
break;
case PARSE_ERROR:
if (verbose) Rf_error("Parse Error: \"%s\"\n", line.toStdString().c_str());
UNPROTECT(2);
program.clear();
return 1;
break;
case PARSE_EOF:
if (verbose) Rf_warning("%s: ParseStatus is eof (%d)\n", name, status);
break;
default:
if (verbose) Rf_warning("%s: ParseStatus is not documented %d\n", name, status);
UNPROTECT(2);
program.clear();
return 1;
break;
}
UNPROTECT(2);
return 0;
}
// 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;
}
SEXP makeNames(std::vector<const char*>& argnames) {
SEXP ans;
PROTECT(ans = Rf_allocVector(STRSXP, argnames.size()));
for(size_t i = 0; i < argnames.size(); i++) {
SET_STRING_ELT(ans, i, Rf_mkChar(argnames[i]));
}
UNPROTECT(1);
return ans;
}
SEXP CharacterVector(const std::vector<std::string> & string_vector){
SEXP ans;
PROTECT(ans = Rf_allocVector(STRSXP, string_vector.size()));
for(int i = 0; i < string_vector.size(); ++i){
SET_STRING_ELT(ans, i, Rf_mkChar(string_vector[i].c_str()));
}
UNPROTECT(1);
return ans;
}
SEXP
R_ocr(SEXP filename, SEXP r_vars, SEXP r_level)
{
SEXP ans = R_NilValue;
int i;
tesseract::TessBaseAPI *api = new tesseract::TessBaseAPI();
if(api->Init(NULL, "eng")) {
PROBLEM "could not intialize tesseract engine."
ERROR;
}
Pix *image = pixRead(CHAR(STRING_ELT(filename, 0)));
api->SetImage(image);
SEXP r_optNames = GET_NAMES(r_vars);
for(i = 0; i < Rf_length(r_vars); i++)
api->SetVariable(CHAR(STRING_ELT(r_optNames, i)), CHAR(STRING_ELT(r_vars, i)));
api->Recognize(0);
tesseract::ResultIterator* ri = api->GetIterator();
tesseract::PageIteratorLevel level = (tesseract::PageIteratorLevel) INTEGER(r_level)[0]; //RIL_WORD;
if(ri != 0) {
int n = 1, i;
while(ri->Next(level)) n++;
// printf("num words %d\n", n);
delete ri; // XXX check
// api->Recognize(0);
ri = api->GetIterator();
SEXP names;
PROTECT(names = NEW_CHARACTER(n));
PROTECT(ans = NEW_NUMERIC(n));
i = 0;
do {
const char* word = ri->GetUTF8Text(level);
float conf = ri->Confidence(level);
SET_STRING_ELT(names, i, Rf_mkChar(word));
REAL(ans)[i] = conf;
delete[] word;
i++;
} while (ri->Next(level));
delete ri; // XXX check
SET_NAMES(ans, names);
UNPROTECT(2);
}
pixDestroy(&image);
return(ans);
}
void omxGlobal::reportProgressStr(const char *msg)
{
ProtectedSEXP theCall(Rf_allocVector(LANGSXP, 3));
SETCAR(theCall, Rf_install("imxReportProgress"));
ProtectedSEXP Rmsg(Rf_allocVector(STRSXP, 1));
SET_STRING_ELT(Rmsg, 0, Rf_mkChar(msg));
SETCADR(theCall, Rmsg);
SETCADDR(theCall, Rf_ScalarInteger(previousReportLength));
Rf_eval(theCall, R_GlobalEnv);
}
/** Get Declared Encodings of Each String
*
* @param str a character vector or an object coercible to
* @return a character vector
*
* @version 0.2-1 (Marek Gagolewski, 2014-03-25)
*
* @version 0.3-1 (Marek Gagolewski, 2014-11-04)
* Issue #112: str_prepare_arg* retvals were not PROTECTed from gc
*/
SEXP stri_enc_mark(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);
// some of them will not be used in this call, but we're lazy
SEXP mark_ascii, mark_latin1, mark_utf8, mark_native, mark_bytes;
STRI__PROTECT(mark_ascii = Rf_mkChar("ASCII"));
STRI__PROTECT(mark_latin1 = Rf_mkChar("latin1"));
STRI__PROTECT(mark_utf8 = Rf_mkChar("UTF-8"));
STRI__PROTECT(mark_native = Rf_mkChar("native"));
STRI__PROTECT(mark_bytes = Rf_mkChar("bytes"));
SEXP ret;
STRI__PROTECT(ret = Rf_allocVector(STRSXP, str_len));
for (R_len_t i=0; i<str_len; ++i) {
SEXP curs = STRING_ELT(str, i);
if (curs == NA_STRING) {
SET_STRING_ELT(ret, i, NA_STRING);
continue;
}
if (IS_ASCII(curs))
SET_STRING_ELT(ret, i, mark_ascii);
else if (IS_UTF8(curs))
SET_STRING_ELT(ret, i, mark_utf8);
else if (IS_BYTES(curs))
SET_STRING_ELT(ret, i, mark_bytes);
else if (IS_LATIN1(curs))
SET_STRING_ELT(ret, i, mark_latin1);
else
SET_STRING_ELT(ret, i, mark_native);
}
STRI__UNPROTECT_ALL
return ret;
STRI__ERROR_HANDLER_END(;/* nothing special to be done on error */)
}
// Sets the names attribute of list to a character vector equivalent
// to 'names'.
SEXP setListNames(SEXP list, const std::vector<std::string> &names) {
int n = Rf_length(list);
if(n != names.size()){
report_error("'list' and 'names' are not the same size in setlistNames");
}
SEXP list_names;
PROTECT(list_names = Rf_allocVector(STRSXP, n));
for(int i = 0; i < n; ++i) {
SET_STRING_ELT(list_names, i, Rf_mkChar(names[i].c_str()));
}
Rf_namesgets(list, list_names);
UNPROTECT(1);
return list;
}
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;
}
static SEXP
rpf_paramInfo_wrapper(SEXP r_spec, SEXP r_paramNum)
{
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 pnum = Rf_asInteger(r_paramNum);
int numParam = (*Glibrpf_model[id].numParam)(spec);
if (pnum < 0 || pnum >= numParam) Rf_error("Item model %d has %d parameters", id, numParam);
const char *type;
double upper, lower;
(*Glibrpf_model[id].paramInfo)(spec, pnum, &type, &upper, &lower);
int len = 3;
SEXP names, ans;
Rf_protect(names = Rf_allocVector(STRSXP, len));
Rf_protect(ans = Rf_allocVector(VECSXP, len));
int lx = 0;
SET_STRING_ELT(names, lx, Rf_mkChar("type"));
SET_VECTOR_ELT(ans, lx, Rf_ScalarString(Rf_mkChar(type)));
SET_STRING_ELT(names, ++lx, Rf_mkChar("upper"));
SET_VECTOR_ELT(ans, lx, Rf_ScalarReal(std::isfinite(upper)? upper : NA_REAL));
SET_STRING_ELT(names, ++lx, Rf_mkChar("lower"));
SET_VECTOR_ELT(ans, lx, Rf_ScalarReal(std::isfinite(lower)? lower : NA_REAL));
Rf_namesgets(ans, names);
UNPROTECT(2);
return ans;
}
static int setFactorColumnName(SEXP dfNames, size_t dfIndex, SEXP levelNames, size_t levelIndex,
SEXP resultNames, size_t resultIndex)
{
if (dfNames != R_NilValue) {
char* colName = concatenateStrings(CHAR(STRING_ELT(dfNames, dfIndex)), CHAR(STRING_ELT(levelNames, levelIndex)));
if (colName == NULL) return ENOMEM;
SET_STRING_ELT(resultNames, resultIndex, Rf_mkChar(colName));
free(colName);
} else {
SET_STRING_ELT(resultNames, resultIndex, STRING_ELT(levelNames, levelIndex));
}
return 0;
}
SEXP get_current_layer()
{
pGEDevDesc curGE = GEcurrentDevice();
LayerDesc *ld = (LayerDesc *) curGE->dev->deviceSpecific;
gint currentIndex = ld->GetCurrentLayerIndex();
SEXP id, layerName, result;
PROTECT(id = NEW_INTEGER(1));
PROTECT(layerName = NEW_CHARACTER(1));
PROTECT(result = NEW_LIST(2));
INTEGER_POINTER(id)[0] =ld->GetLayerIdAt(currentIndex);
SET_STRING_ELT(layerName, 0, Rf_mkChar(ld->GetLayerNameAt(currentIndex)));
SET_VECTOR_ELT(result, 0, id);
SET_VECTOR_ELT(result, 1, layerName);
UNPROTECT(3);
return result;
}
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;
}