SEXP audio_use_driver(SEXP sName) {
if (sName == R_NilValue) { /* equivalent to saying 'load default driver' */
if (!current_driver) load_default_audio_driver(1);
current_driver = audio_drivers.driver;
if (!current_driver || !current_driver->name) {
Rf_warning("no audio drivers are available");
return R_NilValue;
}
return Rf_mkString(current_driver->name);
}
if (TYPEOF(sName) != STRSXP || LENGTH(sName) < 1)
Rf_error("invalid audio driver name");
else {
const char *drv_name = CHAR(STRING_ELT(sName, 0));
audio_driver_list_t *l = &audio_drivers;
if (!current_driver)
load_default_audio_driver(1);
while (l && l->driver) {
if (l->driver->name && !strcmp(l->driver->name, drv_name)) {
current_driver = l->driver;
return sName;
}
l = l->next;
}
Rf_warning("driver '%s' not found", drv_name);
}
return R_NilValue;
}
// 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;
}
// 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;
}
/* Errors that may occur in loading font characters.
Here we just give warnings. */
void errorcode(FT_Error err)
{
switch(err)
{
case 0x10:
Rf_warning("freetype: invalid glyph index");
break;
case 0x11:
Rf_warning("freetype: invalid character code");
break;
case 0x12:
Rf_warning("freetype: unsupported glyph image format");
break;
case 0x13:
Rf_warning("freetype: cannot render this glyph format");
break;
case 0x14:
Rf_warning("freetype: invalid outline");
break;
case 0x15:
Rf_warning("freetype: invalid composite glyph");
break;
case 0x16:
Rf_warning("freetype: too many hints");
break;
case 0x17:
Rf_warning("freetype: invalid pixel size");
break;
default:
Rf_warning("freetype: error code %d", err);
break;
}
}
void omxGlobal::reportProgress(const char *context, FitContext *fc)
{
if (omx_absolute_thread_num() != 0) {
mxLog("omxGlobal::reportProgress called in a thread context (report this bug to developers)");
return;
}
R_CheckUserInterrupt();
time_t now = time(0);
if (Global->maxSeconds > 0 && now > Global->startTime + Global->maxSeconds && !Global->timedOut) {
Global->timedOut = true;
Rf_warning("Time limit of %d minutes %d seconds exceeded",
Global->maxSeconds/60, Global->maxSeconds % 60);
}
if (silent || now - lastProgressReport < 1 || fc->getGlobalComputeCount() == previousComputeCount) return;
lastProgressReport = now;
std::string str;
if (previousReportFit == 0.0 || previousReportFit == fc->fit) {
str = string_snprintf("%s %d %.6g",
context, fc->getGlobalComputeCount(), fc->fit);
} else {
str = string_snprintf("%s %d %.6g %.4g",
context, fc->getGlobalComputeCount(), fc->fit, fc->fit - previousReportFit);
}
reportProgressStr(str.c_str());
previousReportLength = str.size();
previousReportFit = fc->fit;
previousComputeCount = fc->getGlobalComputeCount();
}
int R_curl_callback_progress(SEXP fun,
double dltotal, double dlnow,
double ultotal, double ulnow) {
SEXP down = PROTECT(allocVector(REALSXP, 2));
REAL(down)[0] = dltotal;
REAL(down)[1] = dlnow;
SEXP up = PROTECT(allocVector(REALSXP, 2));
REAL(up)[0] = ultotal;
REAL(up)[1] = ulnow;
SEXP call = PROTECT(LCONS(fun, LCONS(down, LCONS(up, R_NilValue))));
int ok;
SEXP res = PROTECT(R_tryEval(call, R_GlobalEnv, &ok));
if (ok != 0 || pending_interrupt()) {
UNPROTECT(4);
return 0;
}
if (TYPEOF(res) != LGLSXP || length(res) != 1) {
UNPROTECT(4);
Rf_warning("progress callback must return boolean");
return 0;
}
UNPROTECT(4);
return !asLogical(res);
}
/** Read settings flags from a list
*
* may call Rf_error
*
* @param opts_fixed list
* @param allow_overlap
* @return flags
*
* @version 0.4-1 (Marek Gagolewski, 2014-12-07)
*
* @version 0.4-1 (Marek Gagolewski, 2014-12-08)
* add `overlap` option
*/
uint32_t StriContainerByteSearch::getByteSearchFlags(SEXP opts_fixed, bool allow_overlap)
{
uint32_t flags = 0;
if (!isNull(opts_fixed) && !Rf_isVectorList(opts_fixed))
Rf_error(MSG__ARG_EXPECTED_LIST, "opts_fixed"); // error() call allowed here
R_len_t narg = isNull(opts_fixed)?0:LENGTH(opts_fixed);
if (narg > 0) {
SEXP names = Rf_getAttrib(opts_fixed, R_NamesSymbol);
if (names == R_NilValue || LENGTH(names) != narg)
Rf_error(MSG__FIXED_CONFIG_FAILED); // error() call allowed here
for (R_len_t i=0; i<narg; ++i) {
if (STRING_ELT(names, i) == NA_STRING)
Rf_error(MSG__FIXED_CONFIG_FAILED); // error() call allowed here
const char* curname = CHAR(STRING_ELT(names, i));
if (!strcmp(curname, "case_insensitive")) {
bool val = stri__prepare_arg_logical_1_notNA(VECTOR_ELT(opts_fixed, i), "case_insensitive");
if (val) flags |= BYTESEARCH_CASE_INSENSITIVE;
} else if (!strcmp(curname, "overlap") && allow_overlap) {
bool val = stri__prepare_arg_logical_1_notNA(VECTOR_ELT(opts_fixed, i), "overlap");
if (val) flags |= BYTESEARCH_OVERLAP;
} else {
Rf_warning(MSG__INCORRECT_FIXED_OPTION, curname);
}
}
}
return flags;
}
/** WAM operator
*
* @param x numeric
* @param w numeric
* @return numeric of length 1
*/
SEXP wam(SEXP x, SEXP w)
{
x = prepare_arg_numeric(x, "x");
w = prepare_arg_numeric(w, "w");
R_len_t x_length = LENGTH(x);
R_len_t w_length = LENGTH(w);
double* w_tab = REAL(w);
double* x_tab = REAL(x);
if (w_length <= 0) Rf_error(MSG_ARG_TOO_SHORT, "w");
if (x_length <= 0) Rf_error(MSG_ARG_TOO_SHORT, "x");
if (ISNA(w_tab[0]) || ISNA(x_tab[0]))
return Rf_ScalarReal(NA_REAL);
if (x_length != w_length)
Rf_error(MSG__ARGS_EXPECTED_EQUAL_SIZE, "x", "w");
double w_sum = 0.0;
double ret_val = 0.0;
for (R_len_t i=0; i<x_length; ++i) {
if (w_tab[i] < 0)
Rf_error(MSG__ARG_NOT_GE_A, "w", 0.0);
w_sum = w_sum + w_tab[i];
ret_val += w_tab[i]*x_tab[i];
}
if (w_sum > 1.0+EPS || w_sum < 1.0-EPS)
Rf_warning("elements of `w` does not sum up to 1. correcting.");
ret_val /= w_sum;
return Rf_ScalarReal(ret_val);
}
/* stdout() in R only supports text mode, but we need binary */
SEXP stdout_writeBin(SEXP what, SEXP sFlush) {
if (TYPEOF(what) != RAWSXP) Rf_error("invalid content - must be a raw vector");
if (LENGTH(what) && fwrite(RAW(what), LENGTH(what), 1, stdout) != 1)
Rf_warning("write error while writing to stdout");
if (asInteger(sFlush)) fflush(stdout);
return R_NilValue;
}
SEXP dbarts_makeModelMatrixFromDataFrame(SEXP x, SEXP dropColumnsExpr)
{
int errorCode = 0;
SEXP result = R_NilValue;
SEXP dropPatternExpr = R_NilValue;
int protectCount = 0;
size_t numInputColumns = (size_t) rc_getLength(x);
size_t numOutputColumns = 0;
column_type columnTypes[numInputColumns];
getColumnTypes(x, columnTypes);
bool createDropPattern = false;
if (Rf_isLogical(dropColumnsExpr)) {
createDropPattern = LOGICAL(dropColumnsExpr)[0] == TRUE;
if (createDropPattern) {
dropPatternExpr = PROTECT(rc_newList(numInputColumns));
++protectCount;
if (rc_getNames(x) != R_NilValue) rc_setNames(dropPatternExpr, rc_getNames(x));
}
} else if (!createDropPattern && Rf_isVector(dropColumnsExpr)) {
dropPatternExpr = dropColumnsExpr;
}
countMatrixColumns(x, columnTypes, dropPatternExpr, createDropPattern, &numOutputColumns);
size_t numRows = getNumRowsForDataFrame(x);
if (numRows == 0) {
errorCode = EINVAL;
goto mkmm_cleanup;
}
result = PROTECT(rc_newReal(numRows * numOutputColumns));
++protectCount;
rc_setDims(result, (int) numRows, (int) numOutputColumns, -1);
SEXP dimNamesExpr = PROTECT(rc_newList(2));
rc_setDimNames(result, dimNamesExpr);
UNPROTECT(1);
SET_VECTOR_ELT(dimNamesExpr, 1, rc_newCharacter(numOutputColumns));
errorCode = createMatrix(x, numRows, result, columnTypes, dropPatternExpr);
mkmm_cleanup:
if (errorCode != 0) {
if (protectCount > 0) UNPROTECT(protectCount);
Rf_warning("error in makeModelMatrix: %s", strerror(errorCode));
return R_NilValue;
}
if (dropPatternExpr != NULL) Rf_setAttrib(result, Rf_install("drop"), dropPatternExpr);
if (protectCount > 0) UNPROTECT(protectCount);
return result;
}
/**
* Unescape Unicode code points
*
* @param str character vector
* @return character vector
*
* @version 0.1-?? (Marek Gagolewski, 2013-08-17)
*
* @version 0.3-1 (Marek Gagolewski, 2014-11-04)
* Issue #112: str_prepare_arg* retvals were not PROTECTed from gc
*/
SEXP stri_unescape_unicode(SEXP str)
{
PROTECT(str = stri_prepare_arg_string(str, "str")); // prepare string argument
STRI__ERROR_HANDLER_BEGIN(1)
R_len_t str_length = LENGTH(str);
StriContainerUTF16 str_cont(str, str_length, false); // writable
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) || str_cont.get(i).length() == 0)
continue; // leave as-is
str_cont.getWritable(i).setTo(str_cont.get(i).unescape());
if (str_cont.get(i).length() == 0) {
Rf_warning(MSG__INVALID_ESCAPE);
str_cont.setNA(i); // something went wrong
}
}
STRI__UNPROTECT_ALL
return str_cont.toR();
STRI__ERROR_HANDLER_END(;/* nothing special to be done on error */)
}
double totalLogLikelihood(omxMatrix *fitMat)
{
if (fitMat->rows != 1) {
omxFitFunction *ff = fitMat->fitFunction;
if (strEQ(ff->fitType, "MxFitFunctionML") || strEQ(ff->fitType, "imxFitFunctionFIML")) {
// NOTE: Floating-point addition is not
// associative. If we compute this in parallel
// then we introduce non-determinancy.
double sum = 0;
for(int i = 0; i < fitMat->rows; i++) {
sum += log(omxVectorElement(fitMat, i));
}
if (!Global->rowLikelihoodsWarning) {
Rf_warning("%s does not evaluate to a 1x1 matrix. Fixing model by adding "
"mxAlgebra(-2*sum(log(%s)), 'm2ll'), mxFitFunctionAlgebra('m2ll')",
fitMat->name(), fitMat->name());
Global->rowLikelihoodsWarning = true;
}
return sum * Global->llScale;
} else {
omxRaiseErrorf("%s of type %s returned %d values instead of 1, not sure how to proceed",
fitMat->name(), ff->fitType, fitMat->rows);
return nan("unknown");
}
} else {
return fitMat->data[0];
}
}
static void defaultSetVarGroup(omxExpectation *ox, FreeVarGroup *fvg)
{
if (OMX_DEBUG && ox->freeVarGroup && ox->freeVarGroup != fvg) {
Rf_warning("setFreeVarGroup called with different group (%d vs %d) on %s",
ox->name, ox->freeVarGroup->id[0], fvg->id[0]);
}
ox->freeVarGroup = fvg;
}
void omxGlobal::unpackConfidenceIntervals(omxState *currentState)
{
if (unpackedConfidenceIntervals) return;
unpackedConfidenceIntervals = true;
// take care to preserve order
std::vector<ConfidenceInterval*> tmp;
std::swap(tmp, intervalList);
std::set<ConfidenceInterval*, ciCmp> uniqueCIs;
for (int ix=0; ix < (int) tmp.size(); ++ix) {
ConfidenceInterval *ci = tmp[ix];
if (!ci->isWholeAlgebra()) {
auto iter = uniqueCIs.find(ci);
if (iter == uniqueCIs.end()) {
uniqueCIs.insert(ci);
intervalList.push_back(ci);
} else if (ci->cmpBoundAndType(**iter)) {
Rf_warning("Different confidence intervals '%s' and '%s' refer to the same thing",
ci->name.c_str(), (*iter)->name.c_str());
}
continue;
}
omxMatrix *mat = ci->getMatrix(currentState);
for (int cx=0; cx < mat->cols; ++cx) {
for (int rx=0; rx < mat->rows; ++rx) {
ConfidenceInterval *cell = new ConfidenceInterval(*ci);
cell->name = string_snprintf("%s[%d,%d]", ci->name.c_str(), 1+rx, 1+cx);
cell->row = rx;
cell->col = cx;
auto iter = uniqueCIs.find(cell);
if (iter == uniqueCIs.end()) {
uniqueCIs.insert(cell);
intervalList.push_back(cell);
} else {
if (cell->cmpBoundAndType(**iter)) {
Rf_warning("Different confidence intervals '%s' and '%s' refer to the same thing",
cell->name.c_str(), (*iter)->name.c_str());
}
delete cell;
}
}
}
delete ci;
}
}
static void defaultSetFreeVarGroup(omxFitFunction *ff, FreeVarGroup *fvg)
{
if (OMX_DEBUG && ff->freeVarGroup && ff->freeVarGroup != fvg) {
Rf_warning("%s: setFreeVarGroup called with different group (%d vs %d)",
ff->matrix->name(), ff->freeVarGroup->id[0], fvg->id[0]);
}
ff->freeVarGroup = fvg;
}
/** Convert character vector to UTF-32
*
* @param str character vector
* @return list with integer vectors
*
* @version 0.1-?? (Marek Gagolewski)
*
* @version 0.1-?? (Marek Gagolewski, 2013-06-16)
* make StriException-friendly
*
* @version 0.2-1 (Marek Gagolewski, 2014-03-26)
* use vector<UChar32> buf instead of R_alloc;
* warn and set NULL on improper UTF-8 byte sequences
*
* @version 0.2-3 (Marek Gagolewski, 2014-05-12)
* Use UChar32* instead of vector<UChar32> as ::data is C++11
*
* @version 0.3-1 (Marek Gagolewski, 2014-11-04)
* Issue #112: str_prepare_arg* retvals were not PROTECTed from gc
*/
SEXP stri_enc_toutf32(SEXP str)
{
PROTECT(str = stri_prepare_arg_string(str, "str"));
R_len_t n = LENGTH(str);
STRI__ERROR_HANDLER_BEGIN(1)
StriContainerUTF8 str_cont(str, n);
R_len_t bufsize = 1; // to avoid allocating an empty buffer
for (R_len_t i=0; i<n; ++i) {
if (str_cont.isNA(i)) continue;
R_len_t ni = str_cont.get(i).length();
if (ni > bufsize) bufsize = ni;
}
UChar32* buf = (UChar32*)R_alloc((size_t)bufsize, (int)sizeof(UChar32)); // at most bufsize UChars32 (bufsize/4 min.)
if (!buf) throw StriException(MSG__MEM_ALLOC_ERROR);
// deque<UChar32> was slower than using a common, over-sized buf
SEXP ret;
STRI__PROTECT(ret = Rf_allocVector(VECSXP, n)); // all
for (R_len_t i=0; i<n; ++i) {
if (str_cont.isNA(i)) {
SET_VECTOR_ELT(ret, i, R_NilValue);
continue;
}
UChar32 c = (UChar32)0;
const char* s = str_cont.get(i).c_str();
R_len_t sn = str_cont.get(i).length();
R_len_t j = 0;
R_len_t k = 0;
while (c >= 0 && j < sn) {
U8_NEXT(s, j, sn, c);
buf[k++] = (int)c;
}
if (c < 0) {
Rf_warning(MSG__INVALID_UTF8);
SET_VECTOR_ELT(ret, i, R_NilValue);
continue;
}
else {
SEXP conv;
STRI__PROTECT(conv = Rf_allocVector(INTSXP, k));
memcpy(INTEGER(conv), buf, (size_t)sizeof(int)*k);
SET_VECTOR_ELT(ret, i, conv);
STRI__UNPROTECT(1);
}
}
STRI__UNPROTECT_ALL
return ret;
STRI__ERROR_HANDLER_END({ /* do nothing on error */ })
}
void
RXSLT_Warning(xmlXPathParserContextPtr ctxt, const char *msg)
{
/*XXX */
// xsltTransformError(xsltXPathGetTransformContext(ctxt), NULL, xsltXPathGetTransformContext(ctxt)->insert, msg);
Rf_warning(msg);
/* PROBLEM msg
WARN; */
}
/* Rmpc_get_rounding - return the MPC rounding method based on R option.
*
* Args:
* None
* Return value:
* An MPC rounding mode, e.g. MPC_RNDNN.
*/
int Rmpc_get_rounding() {
const char *round_mode = CHAR(STRING_ELT(Rf_GetOption(
Rf_install("mpc.rounding"), R_BaseEnv), 0));
int real_round, imag_round;
if (strlen(round_mode) != 9) {
Rf_warning("Invalid mpc.rounding option, using MPC_RNDNN");
return(MPC_RNDNN);
}
switch (round_mode[7]) {
case 'N':
real_round = GMP_RNDN;
break;
case 'Z':
real_round = GMP_RNDZ;
break;
case 'U':
real_round = GMP_RNDU;
break;
case 'D':
real_round = GMP_RNDD;
break;
default:
Rf_warning("Invalid mpc.rounding option, using MPC_RNDNN");
return(MPC_RNDNN);
}
switch(round_mode[8]) {
case 'N':
imag_round = GMP_RNDN;
break;
case 'Z':
imag_round = GMP_RNDZ;
break;
case 'U':
imag_round = GMP_RNDU;
break;
case 'D':
imag_round = GMP_RNDD;
break;
default:
Rf_warning("Invalid mpc.rounding option, using MPC_RNDNN");
return(MPC_RNDNN);
}
return (RNDC(real_round, imag_round));
}
void handleStructuredError(void* userData, xmlError* error) {
std::string message = std::string(error->message);
message.resize(message.size() - 1); // trim off trailing newline
if (error->level <= 2) {
Rf_warning("%s [%i]", message.c_str(), error->code);
} else {
Rcpp::stop("%s [%i]", message, error->code);
}
}
// [[Rcpp::export]]
Rcpp::List CPL_crs_from_proj4string(Rcpp::CharacterVector p4s) {
OGRSpatialReference ref;
if (ref.importFromProj4(p4s[0]) == OGRERR_NONE)
return get_crs(&ref);
else {
const char *cp = p4s[0];
Rf_warning("GDAL cannot import PROJ.4 string `%s': returning missing CRS\n", cp);
return get_crs(NULL);
}
}
void omxFitFunction::setUnitsFromName(const char *name)
{
if (strEQ(name, "-2lnL")) {
units = FIT_UNITS_MINUS2LL;
ciFun = loglikelihoodCIFun;
} else {
Rf_warning("Unknown units '%s' passed to fit function '%s'",
name, matrix->name());
units = FIT_UNITS_UNKNOWN;
}
}
/** Convert from UTF-32
*
* @param vec integer vector or list with integer vectors
* @return character vector
*
* @version 0.1-?? (Marek Gagolewski)
*
* @version 0.2-1 (Marek Gagolewski, 2014-03-25)
* StriException friently;
* use StriContainerListInt
*
* @version 0.3-1 (Marek Gagolewski, 2014-11-04)
* Issue #112: str_prepare_arg* retvals were not PROTECTed from gc
*/
SEXP stri_enc_fromutf32(SEXP vec)
{
PROTECT(vec = stri_prepare_arg_list_integer(vec, "vec"));
STRI__ERROR_HANDLER_BEGIN(1)
StriContainerListInt vec_cont(vec);
R_len_t vec_n = vec_cont.get_n();
// get required buf size
R_len_t bufsize = 0;
for (R_len_t i=0; i<vec_n; ++i) {
if (!vec_cont.isNA(i) && vec_cont.get(i).size() > bufsize)
bufsize = vec_cont.get(i).size();
}
bufsize = U8_MAX_LENGTH*bufsize+1; // this will surely be sufficient
String8buf buf(bufsize);
char* bufdata = buf.data();
SEXP ret;
STRI__PROTECT(ret = Rf_allocVector(STRSXP, vec_n));
for (R_len_t i=0; i<vec_n; ++i) {
if (vec_cont.isNA(i)) {
SET_STRING_ELT(ret, i, NA_STRING);
continue;
}
const int* cur_data = vec_cont.get(i).data();
R_len_t cur_n = vec_cont.get(i).size();
UChar32 c = (UChar32)0;
R_len_t j = 0;
R_len_t k = 0;
UBool err = FALSE;
while (!err && k < cur_n) {
c = cur_data[k++];
U8_APPEND((uint8_t*)bufdata, j, bufsize, c, err);
// Rf_mkCharLenCE detects embedded nuls, but stops execution completely
if (c == 0) err = TRUE;
}
if (err) {
Rf_warning(MSG__INVALID_CODE_POINT, (int)c);
SET_STRING_ELT(ret, i, NA_STRING);
}
else
SET_STRING_ELT(ret, i, Rf_mkCharLenCE(bufdata, j, CE_UTF8));
}
STRI__UNPROTECT_ALL;
return ret;
STRI__ERROR_HANDLER_END(;/* nothing special to be done on error */)
}
OutputType* applyBinaryOperator(const Op& op,
AttributeCopier attribute_copier,
const LhsType* lhs,
const RhsType* rhs)
{
size_t lhs_size = lhs->size();
size_t rhs_size = rhs->size();
size_t size = std::max(lhs->size(), rhs->size());
if (lhs_size == 0 || rhs_size == 0) {
/* S4-compatibility change: if lhs or rhs are zero length, then
the result is zero length. */
size = 0;
}
OutputType* result = OutputType::create(size);
if (size == 1) {
(*result)[0] = op((*lhs)[0], (*rhs)[0]);
} else if (lhs_size == 1) {
// TODO: move these into a separate function so that the scalar
// case can be inlined.
typename LhsType::value_type lhs_value = (*lhs)[0];
for (size_t i = 0; i < size; i++) {
(*result)[i] = op(lhs_value, (*rhs)[i]);
}
} else if (rhs_size == 1) {
typename RhsType::value_type rhs_value = (*rhs)[0];
for (size_t i = 0; i < size; i++) {
(*result)[i] = op((*lhs)[i], rhs_value);
}
} else if (lhs_size == rhs_size) {
for (size_t i = 0; i < size; i++) {
(*result)[i] = op((*lhs)[i], (*rhs)[i]);
}
} else {
// Full recycling rule.
size_t lhs_i = 0, rhs_i = 0;
for (size_t i = 0; i < size; i++)
{
(*result)[i] = op((*lhs)[lhs_i], (*rhs)[rhs_i]);
lhs_i = lhs_i + 1 == lhs_size ? 0 : lhs_i + 1;
rhs_i = rhs_i + 1 == rhs_size ? 0 : rhs_i + 1;
}
if (lhs_i != 0 || rhs_i != 0) {
Rf_warning(_("longer object length is not"
" a multiple of shorter object length"));
}
}
attribute_copier.copyAttributes(result, lhs, rhs);
return result;
}
/* FIXME: we may want to deprecate this in favor of file("stdin", "rb")
unless there is a substantial performance difference. */
SEXP stdin_read(SEXP sN) {
FILE *f = stdin;
int n = asInteger(sN), i = 0, incomplete = 0;
SEXP res = PROTECT(allocVector(STRSXP, n));
while (i < n && !feof(f) && fgets(buf, sizeof(buf), f)) {
char *eol = strchr(buf, '\n');
if (eol) *eol = 0; else incomplete++;
SET_STRING_ELT(res, i++, mkChar(buf));
}
if (i < n) SETLENGTH(res, i);
UNPROTECT(1);
if (incomplete) Rf_warning("incomplete lines encountered (%d)", incomplete);
return res;
}
//
// Returns errors to R
// Note only case 4 actually returns immediately
// Lower error codes are recoverable
//
static void __err_handler(CPLErr eErrClass, int err_no, const char *msg)
{
switch ( eErrClass )
{
case 0:
break; // #nocov
case 1:
case 2:
Rf_warning("GDAL Message %d: %s\n", err_no, msg); // #nocov
break; // #nocov
case 3:
Rf_warning("GDAL Error %d: %s\n", err_no, msg);
break;
case 4:
Rf_warning("GDAL Error %d: %s\n", err_no, msg); // #nocov
Rcpp::stop("Unrecoverable GDAL error\n"); // #nocov
break;
default:
Rf_warning("Received invalid error class %d (errno %d: %s)\n", eErrClass, err_no, msg); // #nocov
break; // #nocov
}
return;
}
SEXP as_output_vector(SEXP sVector, SEXP sNsep, SEXP sNamesFlag, SEXP sConn) {
R_xlen_t len = XLENGTH(sVector), i;
int key_flag = asInteger(sNamesFlag), mod = 0;
if (TYPEOF(sNsep) != STRSXP || LENGTH(sNsep) != 1)
Rf_error("nsep must be a single string");
char nsep = CHAR(STRING_ELT(sNsep, 0))[0];
char lend = '\n';
SEXP sRnames = Rf_getAttrib(sVector, R_NamesSymbol);
if (requires_as_character(sVector)) {
SEXP as_character = Rf_install("as.character");
SEXP asc = PROTECT(lang2(as_character, sVector));
sVector = eval(asc, R_GlobalEnv);
UNPROTECT(1);
PROTECT(sVector);
mod = 1;
/* since as.character() drops names, we want re-use original names, but that
means we have to check if it is actually meaningful. We do NOT perform
re-cycling since mismatches are unlikely intentional. */
if (key_flag && TYPEOF(sRnames) == STRSXP &&
(TYPEOF(sVector) != STRSXP || XLENGTH(sVector) != XLENGTH(sRnames))) {
Rf_warning("coersion of named object using as.character() yields different length (%ld) than original names (%ld), dropping names", (long) XLENGTH(sVector), (long) XLENGTH(sRnames));
sRnames = R_NilValue;
}
}
SEXPTYPE what = TYPEOF(sVector);
int isConn = inherits(sConn, "connection");
if (isNull(sRnames)) sRnames = 0;
unsigned long row_len = ((unsigned long) guess_size(what));
if (key_flag) row_len += 8;
SEXP buf = dybuf_alloc(isConn ? DEFAULT_CONN_BUFFER_SIZE : row_len, sConn);
for (i = 0; i < len; i++) {
if (key_flag) {
if (sRnames) {
const char *c = CHAR(STRING_ELT(sRnames, i));
dybuf_add(buf, c, strlen(c));
}
dybuf_add1(buf, nsep);
}
store(buf, sVector, i);
dybuf_add1(buf, lend);
}
SEXP res = dybuf_collect(buf);
UNPROTECT(1 + mod);
return res;
}
/** Convert from UTF-32 [single string, internal]
*
* On invalid codepoint, warning is generated and -1 is returned
* @param data UTF-32 codes
* @param ndata number of codes
* @param buf [out] output buffer
* @param bufsize buffer size
* @return number of bytes written
*
* @version 0.1 (Marek Gagolewski)
*/
R_len_t stri__enc_fromutf32(int* data, R_len_t ndata, char* buf, R_len_t bufsize)
{
R_len_t i = 0;
R_len_t k = 0;
UBool err = FALSE;
while (k < ndata) {
UChar32 c = data[k++];
U8_APPEND((uint8_t*)buf, i, bufsize, c, err);
if (err) {
Rf_warning(MSG__INVALID_CODE_POINT, (int)c);
return -1;
}
}
return i;
}
double Clmbr::bisect( double a, double b, double (Clmbr::*fn)(double,int), int k, double value, double crit)
// find x such that value < fn(x) < value + crit if crit > 0 , or value - crit < fn(x) < value if crit < 0
{
double x1= a, x2= b, f1 = (this->*fn)(x1,k) - value, f2 = (this->*fn)(x2,k) - value;
if ( f1*f2>0 || f1==f2 || ISNAN(f1*f2) )
stop( _("'bisect' cannot find interim point from starting values") );
int iteration=0;
while ( fabs(x1-x2) > fabs(crit) && (iteration < bis_it_limit) ) {
const double xmean = (x1+x2)/2, fx = (this->*fn)(xmean,k)-value;
if(f1*fx<=0 && f1!=fx) { x2= xmean; f2= fx; } else { x1= xmean; f1= fx; }
iteration++;
}
if(iteration==bis_it_limit) Rf_warning( _("'bisect' failed to reach tolerance after maximum number of iterations") );
if (crit<0) { if (f1 <= 0) return x1; else return x2; }
else { if (f1 >= 0) return x1; else return x2; }
}
extern "C" SEXP sourcetools_read(SEXP absolutePathSEXP)
{
const char* absolutePath = CHAR(STRING_ELT(absolutePathSEXP, 0));
std::string contents;
bool result = sourcetools::read(absolutePath, &contents);
if (!result)
{
Rf_warning("Failed to read file");
return R_NilValue;
}
sourcetools::r::Protect protect;
SEXP resultSEXP = protect(Rf_allocVector(STRSXP, 1));
SET_STRING_ELT(resultSEXP, 0, Rf_mkCharLen(contents.c_str(), contents.size()));
return resultSEXP;
}
SEXP R_mongo_restore(SEXP con, SEXP ptr_col, SEXP verb) {
bool verbose = Rf_asLogical(verb);
mongoc_collection_t *col = r2col(ptr_col);
bson_reader_t *reader = bson_reader_new_from_handle(con, bson_reader_feed, bson_reader_finalize);
mongoc_bulk_operation_t *bulk = NULL;
const bson_t *b;
bson_error_t err;
int count = 0;
int i = 0;
bool done = false;
bson_t reply;
while(!done) {
//note: default opts uses {ordered:true}
bulk = mongoc_collection_create_bulk_operation_with_opts(col, NULL);
for(i = 0; i < 1000; i++){
if(!(b = bson_reader_read (reader, &done)))
break;
mongoc_bulk_operation_insert (bulk, b);
count++;
}
if(i == 0)
break;
if(!mongoc_bulk_operation_execute (bulk, &reply, &err)){
bson_reader_destroy(reader);
mongoc_bulk_operation_destroy (bulk);
Rf_error(err.message);
}
if(verbose)
Rprintf("\rRestored %d records...", count);
}
if(verbose)
Rprintf("\rDone! Inserted total of %d records.\n", count);
if (!done)
Rf_warning("Failed to read all documents.\n");
bson_reader_destroy(reader);
mongoc_bulk_operation_destroy (bulk);
return Rf_ScalarInteger(count);
}
