SEXP R_mpc_div(SEXP e1, SEXP e2) {
/* N.B. We always use signed integers for e2 given R's type system. */
mpc_t *z = (mpc_t *)malloc(sizeof(mpc_t));
if (Rf_inherits(e1, "mpc")) {
mpc_t *z1 = (mpc_t *)R_ExternalPtrAddr(e1);
if (Rf_inherits(e2, "mpc")) {
mpc_t *z2 = (mpc_t *)R_ExternalPtrAddr(e2);
mpc_init2(*z, max(mpc_get_prec(*z1),
mpc_get_prec(*z2)));
mpc_div(*z, *z1, *z2, Rmpc_get_rounding());
} else if (Rf_isInteger(e2)) {
mpc_init2(*z, mpc_get_prec(*z1));
mpc_div_ui(*z, *z1, INTEGER(e2)[0],
Rmpc_get_rounding());
} else if (Rf_isNumeric(e2)) {
mpc_init2(*z, mpc_get_prec(*z1));
mpfr_t x;
mpfr_init2(x, 53);
mpfr_set_d(x, REAL(e2)[0], GMP_RNDN);
mpc_div_fr(*z, *z1, x, Rmpc_get_rounding());
} else {
Rf_error("Invalid second operand for mpc division.");
}
} else if (Rf_isInteger(e1)) {
if (Rf_inherits(e2, "mpc")) {
/* TODO: sign issue here. mpc_ui_div is
* unsigned, mult -1 if needed by asnwer? */
mpc_t *z2 = (mpc_t *)R_ExternalPtrAddr(e2);
mpc_init2(*z, mpc_get_prec(*z2));
mpc_ui_div(*z, INTEGER(e1)[0], *z2,
Rmpc_get_rounding());
} else {
Rf_error("Invalid second operand for mpc division.");
}
} else if (Rf_isNumeric(e1)) {
if (Rf_inherits(e2, "mpc")) {
mpc_t *z2 = (mpc_t *)R_ExternalPtrAddr(e2);
mpfr_t x;
mpfr_init2(x, 53);
mpfr_set_d(x, REAL(e2)[0], GMP_RNDN);
mpc_fr_div(*z, x, *z2, Rmpc_get_rounding());
} else {
Rf_error("Invalid second operand for mpc division.");
}
} else {
Rf_error("Invalid operands for mpc division.");
}
SEXP retVal = PROTECT(R_MakeExternalPtr((void *)z,
Rf_install("mpc ptr"), R_NilValue));
Rf_setAttrib(retVal, R_ClassSymbol, Rf_mkString("mpc"));
R_RegisterCFinalizerEx(retVal, mpcFinalizer, TRUE);
UNPROTECT(1);
return retVal;
}
SEXP R_mpc_pow(SEXP e1, SEXP e2) {
mpc_t *z = (mpc_t *)malloc(sizeof(mpc_t));
if (Rf_inherits(e1, "mpc")) {
mpc_t *z1 = (mpc_t *)R_ExternalPtrAddr(e1);
if (Rf_inherits(e2, "mpc")) {
mpc_t *z2 = (mpc_t *)R_ExternalPtrAddr(e2);
mpc_init2(*z, max(mpc_get_prec(*z1),
mpc_get_prec(*z2)));
mpc_pow(*z, *z1, *z2, Rmpc_get_rounding());
} else if (Rf_isInteger(e2)) {
mpc_init2(*z, mpc_get_prec(*z1));
mpc_pow_si(*z, *z1, INTEGER(e2)[0],
Rmpc_get_rounding());
} else if (Rf_isNumeric(e2)) {
mpc_init2(*z, mpc_get_prec(*z1));
mpc_pow_d(*z, *z1, REAL(e2)[0], Rmpc_get_rounding());
} else {
Rf_error("Invalid second operand for mpc power.");
}
} else {
Rf_error("Invalid first operand for MPC power.");
}
SEXP retVal = PROTECT(R_MakeExternalPtr((void *)z,
Rf_install("mpc ptr"), R_NilValue));
Rf_setAttrib(retVal, R_ClassSymbol, Rf_mkString("mpc"));
R_RegisterCFinalizerEx(retVal, mpcFinalizer, TRUE);
UNPROTECT(1);
return retVal;
}
inline R_adjacency_list(SEXP num_verts_in,
SEXP num_edges_in,
SEXP R_edges_in,
SEXP R_weights_in)
: Base(Rf_asInteger(num_verts_in))
{
if (!Rf_isNumeric(R_weights_in)) error("R_weights_in should be Numeric");
if (!Rf_isInteger(R_edges_in)) error("R_edges_in should be integer");
int NE = Rf_asInteger(num_edges_in);
int* edges_in = INTEGER(R_edges_in);
if (Rf_isReal(R_weights_in)) {
if (boost::is_integral<R_weight_type>::value)
error("R_weights_in should be integer");
else {
double* weights_in = REAL(R_weights_in);
for (int i = 0; i < NE ; i++, edges_in += 2, weights_in++) {
boost::add_edge(*edges_in, *(edges_in+1),
*weights_in, *this);
}
}
} else {
int* weights_in = INTEGER(R_weights_in);
for (int i = 0; i < NE ; i++, edges_in += 2, weights_in++) {
boost::add_edge(*edges_in, *(edges_in+1), *weights_in, *this);
}
}
}
/* R_mpc - Create an MPC S3 object for arbitrary precision complex numbers.
*
* We currently use external pointers for performance reasons, which
* means that we can't allocVector a list of length(n) MPC objects,
* and instead must instantiate them one at a time, that a caller can
* put into a list if they want, but not a vector.
*
* Args:
* n - An integer, numeric, or complex number to convert to an MPC.
* sprec - The number of bits of precision to use, e.g. 52 for doubles.
*/
SEXP R_mpc(SEXP n, SEXP sprec) {
/* TODO: INTEGER returns 32bit integer but mpfr_prec_t may be
* 64bit. This is based on how mpfr was compiled. Therefore we
* could add this as a configure check? */
mpfr_prec_t prec = INTEGER(sprec)[0];
mpc_t *z = (mpc_t *)malloc(sizeof(mpc_t));
if (z == NULL) {
Rf_error("Could not allocate memory for MPC type.");
}
mpc_init2(*z, prec);
if (Rf_isInteger(n)) {
mpc_set_d(*z, INTEGER(n)[0], Rmpc_get_rounding());
} else if (Rf_isNumeric(n)) {
mpc_set_d(*z, REAL(n)[0], Rmpc_get_rounding());
} else if (Rf_isComplex(n)) {
mpc_set_d_d(*z, COMPLEX(n)[0].r, COMPLEX(n)[0].i,
Rmpc_get_rounding());
} else if (Rf_isString(n)) {
mpc_set_str(*z, CHAR(STRING_ELT(n, 0)), 10,
Rmpc_get_rounding());
} else {
Rf_error("Unsupported type conversion to MPC.");
}
return(MakeMPC(z));
}
ConstVectorView ToBoomVectorView(SEXP v) {
if (!Rf_isNumeric(v)) {
report_error("ToBoomVectorView called with a non-numeric argument.");
}
PROTECT(v = Rf_coerceVector(v, REALSXP));
int n = Rf_length(v);
double *data = REAL(v);
UNPROTECT(1);
return ConstVectorView(data, n, 1);
}
RcppDateVector::RcppDateVector(SEXP vec) {
int i;
if (!Rf_isNumeric(vec) || Rf_isMatrix(vec) || Rf_isLogical(vec))
throw std::range_error("RcppDateVector: invalid numeric vector in constructor");
int len = Rf_length(vec);
if (len == 0)
throw std::range_error("RcppDateVector: null vector in constructor");
v.resize(len);
for (i = 0; i < len; i++)
v[i] = RcppDate( (int) REAL(vec)[i]);
}
RcppDatetime RcppParams::getDatetimeValue(std::string name) {
std::map<std::string,int>::iterator iter = pmap.find(name);
if (iter == pmap.end()) {
std::string mesg = "RcppParams::getDatetimeValue: no such name: ";
throw std::range_error(mesg+name);
}
int posn = iter->second;
SEXP elt = VECTOR_ELT(_params, posn);
if (!Rf_isNumeric(elt) || Rf_length(elt) != 1) {
std::string mesg = "RcppParams::getDateValue: invalide date: ";
throw std::range_error(mesg+name);
}
double d;
if (Rf_isReal(elt)) // R stores POSIXt as a double
d = REAL(elt)[0];
else {
std::string mesg = "RcppParams::getDatetimeValue: invalid value for: ";
throw std::range_error(mesg+name);
}
return RcppDatetime(d);
}
int RcppParams::getIntValue(std::string name) {
std::map<std::string,int>::iterator iter = pmap.find(name);
if (iter == pmap.end()) {
std::string mesg = "RcppParams::getIntValue: no such name: ";
throw std::range_error(mesg+name);
}
int posn = iter->second;
SEXP elt = VECTOR_ELT(_params,posn);
if (!Rf_isNumeric(elt) || Rf_length(elt) != 1) {
std::string mesg = "RcppParams::getIntValue: must be scalar: ";
throw std::range_error(mesg+name);
}
if (Rf_isInteger(elt))
return INTEGER(elt)[0];
else if (Rf_isReal(elt))
return (int)REAL(elt)[0];
else {
std::string mesg = "RcppParams::getIntValue: invalid value for: ";
throw std::range_error(mesg+name);
}
return 0; // never get here
}
std::vector<byte> shape_extractor::getShape(size_t i)
{
std::vector<byte> ret;
SEXP it = 0;
tools::vectorGeneric geometry(m_shape);
it = geometry.at(i);
if (Rf_isNull(it))
{
return ret;
}
else
{
if (TYPEOF(it) == NILSXP || Rf_isNumeric(it))
return ret;
else
{
if (!tools::copy_to(it, ret))
return showError<false>("unknown structure"), ret;
return ret;
}
}
}
SEXP R_mpc_add(SEXP e1, SEXP e2) {
mpc_t *z1 = (mpc_t *)R_ExternalPtrAddr(e1);
mpc_t *z = (mpc_t *)malloc(sizeof(mpc_t));
if (z == NULL) {
Rf_error("Could not allocate memory for MPC type.");
}
if (Rf_inherits(e2, "mpc")) {
mpc_t *z2 = (mpc_t *)R_ExternalPtrAddr(e2);
mpfr_prec_t real_prec, imag_prec;
Rmpc_get_max_prec(&real_prec, &imag_prec, *z1, *z2);
mpc_init3(*z, real_prec, imag_prec);
mpc_add(*z, *z1, *z2, Rmpc_get_rounding());
} else if (Rf_isInteger(e2)) {
mpc_init2(*z, mpc_get_prec(*z1));
mpc_add_ui(*z, *z1, INTEGER(e2)[0], Rmpc_get_rounding());
} else if (Rf_isNumeric(e2)) {
mpfr_t x;
mpfr_init2(x, 53);
// We use GMP_RNDN rather than MPFR_RNDN for compatibility
// with mpfr 2.4.x and earlier as well as more modern versions.
mpfr_set_d(x, REAL(e2)[0], GMP_RNDN);
/* Max of mpc precision z2 and 53 from e2. */
Rprintf("Precision: %d\n", mpc_get_prec(*z1));
mpc_init2(*z, max(mpc_get_prec(*z1), 53));
mpc_add_fr(*z, *z1, x, Rmpc_get_rounding());
} else {
/* TODO(mstokely): Add support for mpfr types here. */
free(z);
Rf_error("Invalid second operand for mpc addition.");
}
SEXP retVal = PROTECT(R_MakeExternalPtr((void *)z,
Rf_install("mpc ptr"), R_NilValue));
Rf_setAttrib(retVal, R_ClassSymbol, Rf_mkString("mpc"));
R_RegisterCFinalizerEx(retVal, mpcFinalizer, TRUE);
UNPROTECT(1);
return retVal;
}
SEXP R_mpc_sub(SEXP e1, SEXP e2) {
mpc_t *z = (mpc_t *)malloc(sizeof(mpc_t));
if (z == NULL) {
Rf_error("Could not allocate memory for MPC type.");
}
if (Rf_inherits(e1, "mpc")) {
Rprintf("It's an mpc");
mpc_t *z1 = (mpc_t *)R_ExternalPtrAddr(e1);
if (Rf_inherits(e2, "mpc")) {
mpc_t *z2 = (mpc_t *)R_ExternalPtrAddr(e2);
mpc_init2(*z, max(mpc_get_prec(*z1),
mpc_get_prec(*z2)));
mpc_sub(*z, *z1, *z2, Rmpc_get_rounding());
} else if (Rf_isInteger(e2)) {
mpc_init2(*z, mpc_get_prec(*z1));
mpc_sub_ui(*z, *z1, INTEGER(e2)[0],
Rmpc_get_rounding());
} else if (Rf_isNumeric(e2)) {
mpfr_t x;
mpfr_init2(x, 53);
mpfr_set_d(x, REAL(e2)[0], GMP_RNDN);
Rprintf("Precision: %d\n", mpc_get_prec(*z1));
mpc_init2(*z, max(mpc_get_prec(*z1), 53));
mpc_sub_fr(*z, *z1, x, Rmpc_get_rounding());
} else {
Rf_error("Unsupported type for operand 2 of MPC subtraction.");
}
} else if (Rf_isInteger(e1)) {
if (Rf_inherits(e2, "mpc")) {
mpc_t *z2 = (mpc_t *)R_ExternalPtrAddr(e2);
mpc_init2(*z, mpc_get_prec(*z2));
mpc_ui_sub(*z, INTEGER(e1)[0], *z2,
Rmpc_get_rounding());
} else {
Rf_error("Unsupported type for operands for MPC subtraction.");
}
} else if (Rf_isNumeric(e1)) {
if (Rf_inherits(e2, "mpc")) {
mpc_t *z2 = (mpc_t *)R_ExternalPtrAddr(e2);
mpc_init2(*z, mpc_get_prec(*z2));
mpfr_t x;
mpfr_init2(x, 53);
mpfr_set_d(x, REAL(e1)[0], GMP_RNDN);
mpc_fr_sub(*z, x, *z2, Rmpc_get_rounding());
} else {
Rf_error("Unsupported type for operands for MPC subtraction.");
}
} else {
/* TODO(mstokely): Add support for mpfr types here. */
Rprintf("It's unknown");
free(z);
Rf_error("Invalid second operand for mpc subtraction.");
}
SEXP retVal = PROTECT(R_MakeExternalPtr((void *)z,
Rf_install("mpc ptr"), R_NilValue));
Rf_setAttrib(retVal, R_ClassSymbol, Rf_mkString("mpc"));
R_RegisterCFinalizerEx(retVal, mpcFinalizer, TRUE);
UNPROTECT(1);
return retVal;
}
char *nvimcom_browser_line(SEXP *x, const char *xname, const char *curenv, const char *prefix, char *p)
{
char xclass[64];
char newenv[512];
char curenvB[512];
char ebuf[64];
char pre[128];
char newpre[128];
int len;
const char *ename;
SEXP listNames, label, lablab, eexp, elmt = R_NilValue;
SEXP cmdSexp, cmdexpr, ans, cmdSexp2, cmdexpr2;
ParseStatus status, status2;
int er = 0;
char buf[128];
if(strlen(xname) > 64)
return p;
if(obbrbufzise < strlen(obbrbuf2) + 1024)
p = nvimcom_grow_obbrbuf();
p = nvimcom_strcat(p, prefix);
if(Rf_isLogical(*x)){
p = nvimcom_strcat(p, "%#");
strcpy(xclass, "logical");
} else if(Rf_isNumeric(*x)){
p = nvimcom_strcat(p, "{#");
strcpy(xclass, "numeric");
} else if(Rf_isFactor(*x)){
p = nvimcom_strcat(p, "'#");
strcpy(xclass, "factor");
} else if(Rf_isValidString(*x)){
p = nvimcom_strcat(p, "\"#");
strcpy(xclass, "character");
} else if(Rf_isFunction(*x)){
p = nvimcom_strcat(p, "(#");
strcpy(xclass, "function");
} else if(Rf_isFrame(*x)){
p = nvimcom_strcat(p, "[#");
strcpy(xclass, "data.frame");
} else if(Rf_isNewList(*x)){
p = nvimcom_strcat(p, "[#");
strcpy(xclass, "list");
} else if(Rf_isS4(*x)){
p = nvimcom_strcat(p, "<#");
strcpy(xclass, "s4");
} else if(TYPEOF(*x) == PROMSXP){
p = nvimcom_strcat(p, "&#");
strcpy(xclass, "lazy");
} else {
p = nvimcom_strcat(p, "=#");
strcpy(xclass, "other");
}
PROTECT(lablab = allocVector(STRSXP, 1));
SET_STRING_ELT(lablab, 0, mkChar("label"));
PROTECT(label = getAttrib(*x, lablab));
p = nvimcom_strcat(p, xname);
p = nvimcom_strcat(p, "\t");
if(length(label) > 0){
if(Rf_isValidString(label)){
snprintf(buf, 127, "%s", CHAR(STRING_ELT(label, 0)));
p = nvimcom_strcat(p, buf);
} else {
if(labelerr)
p = nvimcom_strcat(p, "Error: label isn't \"character\".");
}
}
p = nvimcom_strcat(p, "\n");
UNPROTECT(2);
if(strcmp(xclass, "list") == 0 || strcmp(xclass, "data.frame") == 0 || strcmp(xclass, "s4") == 0){
strncpy(curenvB, curenv, 500);
if(xname[0] == '[' && xname[1] == '['){
curenvB[strlen(curenvB) - 1] = 0;
}
if(strcmp(xclass, "s4") == 0)
snprintf(newenv, 500, "%s%s@", curenvB, xname);
else
snprintf(newenv, 500, "%s%s$", curenvB, xname);
if((nvimcom_get_list_status(newenv, xclass) == 1)){
len = strlen(prefix);
if(nvimcom_is_utf8){
int j = 0, i = 0;
while(i < len){
if(prefix[i] == '\xe2'){
i += 3;
if(prefix[i-1] == '\x80' || prefix[i-1] == '\x94'){
pre[j] = ' '; j++;
} else {
pre[j] = '\xe2'; j++;
pre[j] = '\x94'; j++;
pre[j] = '\x82'; j++;
}
} else {
pre[j] = prefix[i];
i++, j++;
}
}
pre[j] = 0;
} else {
for(int i = 0; i < len; i++){
if(prefix[i] == '-' || prefix[i] == '`')
pre[i] = ' ';
else
pre[i] = prefix[i];
}
pre[len] = 0;
}
sprintf(newpre, "%s%s", pre, strT);
if(strcmp(xclass, "s4") == 0){
snprintf(buf, 127, "slotNames(%s%s)", curenvB, xname);
PROTECT(cmdSexp = allocVector(STRSXP, 1));
SET_STRING_ELT(cmdSexp, 0, mkChar(buf));
PROTECT(cmdexpr = R_ParseVector(cmdSexp, -1, &status, R_NilValue));
if (status != PARSE_OK) {
p = nvimcom_strcat(p, "nvimcom error: invalid value in slotNames(");
p = nvimcom_strcat(p, xname);
p = nvimcom_strcat(p, ")\n");
} else {
PROTECT(ans = R_tryEval(VECTOR_ELT(cmdexpr, 0), R_GlobalEnv, &er));
if(er){
p = nvimcom_strcat(p, "nvimcom error: ");
p = nvimcom_strcat(p, xname);
p = nvimcom_strcat(p, "\n");
} else {
len = length(ans);
if(len > 0){
int len1 = len - 1;
for(int i = 0; i < len; i++){
ename = CHAR(STRING_ELT(ans, i));
snprintf(buf, 127, "%s%s@%s", curenvB, xname, ename);
PROTECT(cmdSexp2 = allocVector(STRSXP, 1));
SET_STRING_ELT(cmdSexp2, 0, mkChar(buf));
PROTECT(cmdexpr2 = R_ParseVector(cmdSexp2, -1, &status2, R_NilValue));
if (status2 != PARSE_OK) {
p = nvimcom_strcat(p, "nvimcom error: invalid code \"");
p = nvimcom_strcat(p, xname);
p = nvimcom_strcat(p, "@");
p = nvimcom_strcat(p, ename);
p = nvimcom_strcat(p, "\"\n");
} else {
PROTECT(elmt = R_tryEval(VECTOR_ELT(cmdexpr2, 0), R_GlobalEnv, &er));
if(i == len1)
sprintf(newpre, "%s%s", pre, strL);
p = nvimcom_browser_line(&elmt, ename, newenv, newpre, p);
UNPROTECT(1);
}
UNPROTECT(2);
}
}
}
UNPROTECT(1);
}
UNPROTECT(2);
} else {
PROTECT(listNames = getAttrib(*x, R_NamesSymbol));
len = length(listNames);
if(len == 0){ /* Empty list? */
int len1 = length(*x);
if(len1 > 0){ /* List without names */
len1 -= 1;
for(int i = 0; i < len1; i++){
sprintf(ebuf, "[[%d]]", i + 1);
elmt = VECTOR_ELT(*x, i);
p = nvimcom_browser_line(&elmt, ebuf, newenv, newpre, p);
}
sprintf(newpre, "%s%s", pre, strL);
sprintf(ebuf, "[[%d]]", len1 + 1);
PROTECT(elmt = VECTOR_ELT(*x, len));
p = nvimcom_browser_line(&elmt, ebuf, newenv, newpre, p);
UNPROTECT(1);
}
} else { /* Named list */
len -= 1;
for(int i = 0; i < len; i++){
PROTECT(eexp = STRING_ELT(listNames, i));
ename = CHAR(eexp);
UNPROTECT(1);
if(ename[0] == 0){
sprintf(ebuf, "[[%d]]", i + 1);
ename = ebuf;
}
PROTECT(elmt = VECTOR_ELT(*x, i));
p = nvimcom_browser_line(&elmt, ename, newenv, newpre, p);
UNPROTECT(1);
}
sprintf(newpre, "%s%s", pre, strL);
ename = CHAR(STRING_ELT(listNames, len));
if(ename[0] == 0){
sprintf(ebuf, "[[%d]]", len + 1);
ename = ebuf;
}
PROTECT(elmt = VECTOR_ELT(*x, len));
p = nvimcom_browser_line(&elmt, ename, newenv, newpre, p);
UNPROTECT(1);
}
UNPROTECT(1); /* listNames */
}
}
}
return p;
}
long shape_extractor::at(size_t i, IGeometry **ppNewGeom)
{
if (m_gt == esriGeometryNull)
return S_FALSE;
CComQIPtr<IGeometry> ipNewShape;
if (m_gt == esriGeometryPoint)
{
HRESULT hr = newShape(m_gt, m_ipSR, m_hasZ, m_hasM, &ipNewShape);
if (hr != S_OK)
return showError<true>(L"create new geometry failed"), hr;
CComQIPtr<IPoint> ipPoint(ipNewShape);
double x, y, z, m;
if (m_as_matrix)
{
ATLASSERT(Rf_isMatrix(m_shape));
size_t r = m_len;//INTEGER(dims)[0];
x = REAL(m_shape)[i];
y = REAL(m_shape)[i + r];
if (m_hasZ || m_hasM)
{
m = z = REAL(m_shape)[i + (r*2)];
if (m_hasZ && m_hasM)
m = REAL(m_shape)[i + (r*3)];
}
}
else
{
x = REAL(m_parts[0])[i];
y = REAL(m_parts[1])[i];
if (m_hasZ || m_hasM)
{
double z, m;
m = z = REAL(m_parts[2])[i];
if (m_hasZ && m_hasM)
m = REAL(m_parts[3])[i];
}
}
ipPoint->PutCoords(x, y);
if (m_hasZ) ipPoint->put_Z(z);
if (m_hasM) ipPoint->put_M(m);
return ipNewShape.CopyTo(ppNewGeom);
}
SEXP it = 0;
tools::vectorGeneric geometry(m_shape);
HRESULT hr = newShape(m_gt, m_ipSR, false, false, &ipNewShape);
if (hr != S_OK)
return showError<true>(L"create new geometry failed"), hr;
it = geometry.at(i);
if (Rf_isNull(it))
{
ipNewShape->SetEmpty();
}
else
{
HRESULT hr = S_FALSE;
if (TYPEOF(it) == NILSXP || Rf_isNumeric(it))
hr = ipNewShape->SetEmpty();
else
{
std::vector<BYTE> buff;
if (!tools::copy_to(it, buff))
return showError<false>(L"unknown structure"), E_FAIL;
CComQIPtr<IESRIShape2> ipShape(ipNewShape);
long buffSize = (long)buff.size();
hr = ipShape->ImportFromESRIShapeEx(esriShapeImportNoSwap | esriShapeImportNonTrusted, &buffSize, &buff[0]);
}
if (hr != S_OK)
return showError<true>(L"create new geometry"), hr;
}
return ipNewShape.CopyTo(ppNewGeom);
}