/** WMin operator
*
* @param x numeric
* @param w numeric
* @return numeric of length 1
*/
SEXP wmin(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 ret_val = DBL_MAX;
for (R_len_t i=0; i<x_length; ++i) {
double tmp = max(w_tab[i], x_tab[i]);
if (ret_val > tmp) ret_val = tmp;
}
return Rf_ScalarReal(ret_val);
}
/** 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);
}
static SEXP rc_reply2R(redisReply *reply) {
SEXP res;
int i, n;
/* Rprintf("rc_reply2R, type=%d\n", reply->type); */
switch (reply->type) {
case REDIS_REPLY_STATUS:
case REDIS_REPLY_ERROR:
res = PROTECT(Rf_allocVector(STRSXP, 1));
SET_STRING_ELT(res, 0, Rf_mkCharLenCE(reply->str, reply->len, CE_UTF8));
UNPROTECT(1);
return res;
case REDIS_REPLY_STRING:
res = Rf_allocVector(RAWSXP, reply->len);
memcpy(RAW(res), reply->str, reply->len);
return res;
case REDIS_REPLY_NIL:
return R_NilValue;
case REDIS_REPLY_INTEGER:
if (reply->integer > INT_MAX || reply->integer < INT_MIN)
return Rf_ScalarReal((double) reply->integer);
return Rf_ScalarInteger((int) reply->integer);
case REDIS_REPLY_ARRAY:
res = PROTECT(Rf_allocVector(VECSXP, reply->elements));
n = reply->elements;
for (i = 0; i < n; i++)
SET_VECTOR_ELT(res, i, rc_reply2R(reply->element[i]));
UNPROTECT(1);
return res;
default:
Rf_error("unknown redis reply type %d", reply->type);
}
return R_NilValue;
}
/** Get current date-time
*
* @return POSIXct
*
* @version 0.5-1 (Marek Gagolewski, 2014-12-29)
*/
SEXP stri_datetime_now()
{
UDate now = Calendar::getNow();
SEXP ret;
PROTECT(ret = Rf_ScalarReal(((double)now)/1000.0)); // msec.->sec.
stri__set_class_POSIXct(ret);
UNPROTECT(1);
return ret;
}
SEXP R_mongo_collection_count (SEXP ptr, SEXP ptr_filter){
mongoc_collection_t *col = r2col(ptr);
bson_t *filter = r2bson(ptr_filter);
bson_error_t err;
int64_t count = mongoc_collection_count_documents (col, filter, NULL, NULL, NULL, &err);
if (count < 0)
stop(err.message);
//R does not support int64
return Rf_ScalarReal((double) count);
}
void omxLISRELExpectation::populateAttr(SEXP algebra)
{
auto oo = this;
ProtectedSEXP RnumStat(Rf_ScalarReal(omxDataDF(oo->data)));
Rf_setAttrib(algebra, Rf_install("numStats"), RnumStat);
/*
omxLISRELExpectation* oro = (omxLISRELExpectation*) (oo->argStruct);
omxMatrix* LX = oro->LX;
omxMatrix* LY = oro->LY;
omxMatrix* BE = oro->BE;
omxMatrix* GA = oro->GA;
omxMatrix* PH = oro->PH;
omxMatrix* PS = oro->PS;
omxMatrix* TD = oro->TD;
omxMatrix* TE = oro->TE;
omxMatrix* TH = oro->TH;
omxMatrix* LXPH = oro->LXPH;
omxMatrix* GAPH = oro->GAPH;
omxMatrix* W = oro->W;
omxMatrix* U = oro->U;
omxMatrix* I = oro->I;
int numIters = oro->numIters;
double oned = 1.0, zerod = 0.0;
omxRecompute(LX);
omxRecompute(LY);
*/ //This block of code works fine but because I do not use any of it later, it throws a huge block of Rf_warnings about unused variables.
// In general, I do not yet understand what this function needs to do.
/*
omxShallowInverse(numIters, BE, Z, Ax, I ); // Z = (I-A)^-1
if(OMX_DEBUG_ALGEBRA) { mxLog("....DGEMM: %c %c \n %d %d %d \n %f \n %x %d %x %d \n %f %x %d.", *(Z->majority), *(S->majority), (Z->rows), (S->cols), (S->rows), oned, Z->data, (Z->leading), S->data, (S->leading), zerod, Ax->data, (Ax->leading));}
// F77_CALL(omxunsafedgemm)(Z->majority, S->majority, &(Z->rows), &(S->cols), &(S->rows), &oned, Z->data, &(Z->leading), S->data, &(S->leading), &zerod, Ax->data, &(Ax->leading)); // X = ZS
omxDGEMM(FALSE, FALSE, oned, Z, S, zerod, Ax);
if(OMX_DEBUG_ALGEBRA) { mxLog("....DGEMM: %c %c %d %d %d %f %x %d %x %d %f %x %d.", *(Ax->majority), *(Z->minority), (Ax->rows), (Z->rows), (Z->cols), oned, X->data, (X->leading), Z->data, (Z->lagging), zerod, Ax->data, (Ax->leading));}
// F77_CALL(omxunsafedgemm)(Ax->majority, Z->minority, &(Ax->rows), &(Z->rows), &(Z->cols), &oned, Ax->data, &(Ax->leading), Z->data, &(Z->leading), &zerod, Ax->data, &(Ax->leading));
omxDGEMM(FALSE, TRUE, oned, Ax, Z, zerod, Ax);
// Ax = ZSZ' = Covariance matrix including latent variables
SEXP expCovExt;
Rf_protect(expCovExt = Rf_allocMatrix(REALSXP, Ax->rows, Ax->cols));
for(int row = 0; row < Ax->rows; row++)
for(int col = 0; col < Ax->cols; col++)
REAL(expCovExt)[col * Ax->rows + row] =
omxMatrixElement(Ax, row, col);
setAttrib(algebra, Rf_install("UnfilteredExpCov"), expCovExt);
*/
}
SEXP R_mpc_imag(SEXP e1) {
if (Rf_inherits(e1, "mpc")) {
mpc_t *z1 = (mpc_t *)R_ExternalPtrAddr(e1);
if (mpfr_fits_sint_p(mpc_imagref(*z1), GMP_RNDN)) {
return Rf_ScalarReal(mpfr_get_d(mpc_imagref(*z1),
GMP_RNDN));
} else {
Rf_error("Imaginary part doesn't fit in numeric.");
}
} else {
Rf_error("Invalid operand for MPC log.");
}
return R_NilValue; /* Not reached */
}
SEXP R_mpc_arg(SEXP e1) {
mpfr_t x;
if (Rf_inherits(e1, "mpc")) {
mpc_t *z1 = (mpc_t *)R_ExternalPtrAddr(e1);
mpc_arg(x, *z1, GMP_RNDN);
if (mpfr_fits_sint_p(x, GMP_RNDN)) {
return Rf_ScalarReal(mpfr_get_d(x, GMP_RNDN));
} else {
Rf_error("Arg doesn't fit in numeric.");
}
} else {
Rf_error("Invalid operand for MPC log.");
}
return R_NilValue; /* Not reached */
}
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;
}
void omxPopulateNormalAttributes(omxExpectation *ox, SEXP algebra) {
if(OMX_DEBUG) { mxLog("Populating Normal Attributes."); }
omxNormalExpectation* one = (omxNormalExpectation*) (ox->argStruct);
omxMatrix *cov = one->cov;
omxMatrix *means = one->means;
omxRecompute(cov, NULL);
if(means != NULL) omxRecompute(means, NULL);
{
SEXP expCovExt;
ScopedProtect p1(expCovExt, Rf_allocMatrix(REALSXP, cov->rows, cov->cols));
for(int row = 0; row < cov->rows; row++)
for(int col = 0; col < cov->cols; col++)
REAL(expCovExt)[col * cov->rows + row] =
omxMatrixElement(cov, row, col);
Rf_setAttrib(algebra, Rf_install("ExpCov"), expCovExt);
}
if (means != NULL) {
SEXP expMeanExt;
ScopedProtect p1(expMeanExt, Rf_allocMatrix(REALSXP, means->rows, means->cols));
for(int row = 0; row < means->rows; row++)
for(int col = 0; col < means->cols; col++)
REAL(expMeanExt)[col * means->rows + row] =
omxMatrixElement(means, row, col);
Rf_setAttrib(algebra, Rf_install("ExpMean"), expMeanExt);
} else {
SEXP expMeanExt;
ScopedProtect p1(expMeanExt, Rf_allocMatrix(REALSXP, 0, 0));
Rf_setAttrib(algebra, Rf_install("ExpMean"), expMeanExt);
}
Rf_setAttrib(algebra, Rf_install("numStats"), Rf_ScalarReal(omxDataDF(ox->data)));
}
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 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;
}
void omxPopulateWLSAttributes(omxFitFunction *oo, SEXP algebra) {
if(OMX_DEBUG) { mxLog("Populating WLS Attributes."); }
omxWLSFitFunction *argStruct = ((omxWLSFitFunction*)oo->argStruct);
omxMatrix *expCovInt = argStruct->expectedCov; // Expected covariance
omxMatrix *expMeanInt = argStruct->expectedMeans; // Expected means
omxMatrix *weightInt = argStruct->weights; // Expected means
SEXP expCovExt, expMeanExt, gradients;
Rf_protect(expCovExt = Rf_allocMatrix(REALSXP, expCovInt->rows, expCovInt->cols));
for(int row = 0; row < expCovInt->rows; row++)
for(int col = 0; col < expCovInt->cols; col++)
REAL(expCovExt)[col * expCovInt->rows + row] =
omxMatrixElement(expCovInt, row, col);
if (expMeanInt != NULL) {
Rf_protect(expMeanExt = Rf_allocMatrix(REALSXP, expMeanInt->rows, expMeanInt->cols));
for(int row = 0; row < expMeanInt->rows; row++)
for(int col = 0; col < expMeanInt->cols; col++)
REAL(expMeanExt)[col * expMeanInt->rows + row] =
omxMatrixElement(expMeanInt, row, col);
} else {
Rf_protect(expMeanExt = Rf_allocMatrix(REALSXP, 0, 0));
}
if(OMX_DEBUG_ALGEBRA) {omxPrintMatrix(weightInt, "...WLS Weight Matrix: W"); }
SEXP weightExt = NULL;
if (weightInt) {
Rf_protect(weightExt = Rf_allocMatrix(REALSXP, weightInt->rows, weightInt->cols));
for(int row = 0; row < weightInt->rows; row++)
for(int col = 0; col < weightInt->cols; col++)
REAL(weightExt)[col * weightInt->rows + row] = weightInt->data[col * weightInt->rows + row];
}
if(0) { /* TODO fix for new internal API
int nLocs = Global->numFreeParams;
double gradient[Global->numFreeParams];
for(int loc = 0; loc < nLocs; loc++) {
gradient[loc] = NA_REAL;
}
//oo->gradientFun(oo, gradient);
Rf_protect(gradients = Rf_allocMatrix(REALSXP, 1, nLocs));
for(int loc = 0; loc < nLocs; loc++)
REAL(gradients)[loc] = gradient[loc];
*/
} else {
Rf_protect(gradients = Rf_allocMatrix(REALSXP, 0, 0));
}
if(OMX_DEBUG) { mxLog("Installing populated WLS Attributes."); }
Rf_setAttrib(algebra, Rf_install("expCov"), expCovExt);
Rf_setAttrib(algebra, Rf_install("expMean"), expMeanExt);
if (weightExt) Rf_setAttrib(algebra, Rf_install("weights"), weightExt);
Rf_setAttrib(algebra, Rf_install("gradients"), gradients);
Rf_setAttrib(algebra, Rf_install("SaturatedLikelihood"), Rf_ScalarReal(0));
//Rf_setAttrib(algebra, Rf_install("IndependenceLikelihood"), Rf_ScalarReal(0));
Rf_setAttrib(algebra, Rf_install("ADFMisfit"), Rf_ScalarReal(omxMatrixElement(oo->matrix, 0, 0)));
}
/** 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;
}
// 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 getNodeLayouts(Agraph_t *g) {
Agnode_t *node;
SEXP outLst, nlClass, xyClass, curXY, curNL;
SEXP curLab, labClass;
int i, nodes;
char *tmpString;
if (g == NULL) error("getNodeLayouts passed a NULL graph");
nlClass = MAKE_CLASS("AgNode");
xyClass = MAKE_CLASS("xyPoint");
labClass = MAKE_CLASS("AgTextLabel");
/* tmpString is used to convert a char to a char* w/ labels */
tmpString = (char *)R_alloc(2, sizeof(char));
if (tmpString == NULL) error("Allocation error in getNodeLayouts");
nodes = agnnodes(g);
node = agfstnode(g);
PROTECT(outLst = allocVector(VECSXP, nodes));
for (i = 0; i < nodes; i++) {
PROTECT(curNL = NEW_OBJECT(nlClass));
PROTECT(curXY = NEW_OBJECT(xyClass));
SET_SLOT(curXY,Rf_install("x"),Rf_ScalarInteger(node->u.coord.x));
SET_SLOT(curXY,Rf_install("y"),Rf_ScalarInteger(node->u.coord.y));
SET_SLOT(curNL,Rf_install("center"),curXY);
SET_SLOT(curNL,Rf_install("height"),Rf_ScalarInteger(node->u.ht));
SET_SLOT(curNL,Rf_install("rWidth"),Rf_ScalarInteger(node->u.rw));
SET_SLOT(curNL,Rf_install("lWidth"),Rf_ScalarInteger(node->u.lw));
SET_SLOT(curNL,Rf_install("name"), Rgraphviz_ScalarStringOrNull(node->name));
SET_SLOT(curNL, Rf_install("color"), Rgraphviz_ScalarStringOrNull(agget(node, "color")));
SET_SLOT(curNL, Rf_install("fillcolor"), Rgraphviz_ScalarStringOrNull(agget(node, "fillcolor")));
SET_SLOT(curNL, Rf_install("shape"), Rgraphviz_ScalarStringOrNull(agget(node, "shape")));
SET_SLOT(curNL, Rf_install("style"), Rgraphviz_ScalarStringOrNull(agget(node, "style")));
PROTECT(curLab = NEW_OBJECT(labClass));
if (ND_label(node) == NULL) {
} else if (ND_label(node)->u.txt.para != NULL) {
SET_SLOT(curLab, Rf_install("labelText"),
Rgraphviz_ScalarStringOrNull(ND_label(node)->text));
snprintf(tmpString, 2, "%c",ND_label(node)->u.txt.para->just);
SET_SLOT(curLab, Rf_install("labelJust"), Rgraphviz_ScalarStringOrNull(tmpString));
SET_SLOT(curLab, Rf_install("labelWidth"),
Rf_ScalarInteger(ND_label(node)->u.txt.para->width));
/* Get the X/Y location of the label */
PROTECT(curXY = NEW_OBJECT(xyClass));
#if GRAPHVIZ_MAJOR == 2 && GRAPHVIZ_MINOR > 20
SET_SLOT(curXY, Rf_install("x"), Rf_ScalarInteger(ND_label(node)->pos.x));
SET_SLOT(curXY, Rf_install("y"), Rf_ScalarInteger(ND_label(node)->pos.y));
#else
SET_SLOT(curXY, Rf_install("x"), Rf_ScalarInteger(node->u.label->p.x));
SET_SLOT(curXY, Rf_install("y"), Rf_ScalarInteger(node->u.label->p.y));
#endif
SET_SLOT(curLab, Rf_install("labelLoc"), curXY);
UNPROTECT(1);
SET_SLOT(curLab, Rf_install("labelColor"), Rgraphviz_ScalarStringOrNull(node->u.label->fontcolor));
SET_SLOT(curLab, Rf_install("labelFontsize"), Rf_ScalarReal(node->u.label->fontsize));
}
SET_SLOT(curNL, Rf_install("txtLabel"), curLab);
SET_ELEMENT(outLst, i, curNL);
node = agnxtnode(g,node);
UNPROTECT(3);
}
UNPROTECT(1);
return(outLst);
}
SEXP jsClientLib_jsclient_device_(SEXP nameSEXP, SEXP backgroundSEXP, SEXP widthSEXP, SEXP heightSEXP, SEXP pointsizeSEXP) {
const char *name = CHAR(STRING_ELT(nameSEXP, 0));
const char *background = CHAR(STRING_ELT(backgroundSEXP, 0));
int rslt = jsclient_device_( name, background, Rf_asInteger( widthSEXP ), Rf_asInteger( heightSEXP ), Rf_asInteger( pointsizeSEXP ));
return Rf_ScalarReal(rslt);
}
SEXP Rgraphviz_buildEdgeList(SEXP nodes, SEXP edgeL, SEXP edgeMode,
SEXP subGList, SEXP edgeNames,
SEXP removedEdges, SEXP edgeAttrs,
SEXP defAttrs) {
int x, y, curEle = 0;
SEXP from;
SEXP peList;
SEXP peClass, curPE;
SEXP curAttrs, curFrom, curTo, curWeights = R_NilValue;
SEXP attrNames;
SEXP tmpToSTR, tmpWtSTR, tmpW;
SEXP curSubG, subGEdgeL, subGEdges, subGNodes, elt;
SEXP recipAttrs, newRecipAttrs, recipAttrNames, newRecipAttrNames;
SEXP goodEdgeNames;
SEXP toName;
SEXP recipPE;
char *edgeName, *recipName;
int i, j, k, nSubG;
int nEdges = length(edgeNames);
if (length(edgeL) == 0)
return(allocVector(VECSXP, 0));
PROTECT(peClass = MAKE_CLASS("pEdge"));
PROTECT(peList = allocVector(VECSXP, nEdges -
length(removedEdges)));
PROTECT(goodEdgeNames = allocVector(STRSXP, nEdges -
length(removedEdges)));
PROTECT(curAttrs = allocVector(VECSXP, 3));
PROTECT(attrNames = allocVector(STRSXP, 3));
/* TODO: get rid of attrs "arrowhead"/"arrowtail", "dir" is sufficient */
SET_STRING_ELT(attrNames, 0, mkChar("arrowhead"));
SET_STRING_ELT(attrNames, 1, mkChar("weight"));
SET_STRING_ELT(attrNames, 2, mkChar("dir"));
setAttrib(curAttrs, R_NamesSymbol, attrNames);
PROTECT(from = getAttrib(edgeL, R_NamesSymbol));
nSubG = length(subGList);
/* For each edge, create a new object of class pEdge */
/* and then assign the 'from' and 'to' strings as */
/* as well as the default attrs (arrowhead & weight) */
for (x = 0; x < length(from); x++) {
PROTECT(curFrom = allocVector(STRSXP, 1));
SET_STRING_ELT(curFrom, 0, STRING_ELT(from, x));
if (length(VECTOR_ELT(edgeL, x)) == 0)
error("Invalid edgeList element given to buildEdgeList in Rgraphviz, is NULL");
PROTECT(curTo = coerceVector(VECTOR_ELT(VECTOR_ELT(edgeL, x), 0),
INTSXP));
if (length(VECTOR_ELT(edgeL, x)) > 1) {
curWeights = VECTOR_ELT(VECTOR_ELT(edgeL, x), 1);
}
if (curWeights == R_NilValue || (length(curWeights) != length(curTo))) {
curWeights = allocVector(REALSXP, length(curTo));
for (i = 0; i < length(curWeights); i++)
REAL(curWeights)[i] = 1;
}
PROTECT(curWeights);
for (y = 0; y < length(curTo); y++) {
PROTECT(toName = STRING_ELT(from, INTEGER(curTo)[y]-1));
edgeName = (char *)malloc((strlen(STR(curFrom))+
strlen(CHAR(toName)) + 2) *
sizeof(char));
sprintf(edgeName, "%s~%s", STR(curFrom), CHAR(toName));
/* See if this edge is a removed edge */
for (i = 0; i < length(removedEdges); i++) {
if (strcmp(CHAR(STRING_ELT(edgeNames,
INTEGER(removedEdges)[i]-1)),
edgeName) == 0)
break;
}
if (i < length(removedEdges)) {
/* This edge is to be removed */
if (strcmp(STR(edgeMode), "directed") == 0) {
/* Find the recip and add 'open' to tail */
recipName = (char *)malloc((strlen(STR(curFrom))+
strlen(CHAR(toName)) + 2) *
sizeof(char));
sprintf(recipName, "%s~%s", CHAR(toName), STR(curFrom));
for (k = 0; k < curEle; k++) {
if (strcmp(CHAR(STRING_ELT(goodEdgeNames, k)),
recipName) == 0)
break;
}
free(recipName);
PROTECT(recipPE = VECTOR_ELT(peList, k));
recipAttrs = GET_SLOT(recipPE, Rf_install("attrs"));
recipAttrNames = getAttrib(recipAttrs,
R_NamesSymbol);
/* We need to add this to the current set of
recipAttrs, so create a new list which is one
element longer and copy everything over, adding
the new element */
PROTECT(newRecipAttrs = allocVector(VECSXP,
length(recipAttrs)+1));
PROTECT(newRecipAttrNames = allocVector(STRSXP,
length(recipAttrNames)+1));
for (j = 0; j < length(recipAttrs); j++) {
if ( !strcmp(CHAR(STRING_ELT(recipAttrNames, j)), "dir") )
SET_VECTOR_ELT(newRecipAttrs, j, mkString("both"));
else
SET_VECTOR_ELT(newRecipAttrs, j,
VECTOR_ELT(recipAttrs, j));
SET_STRING_ELT(newRecipAttrNames, j,
STRING_ELT(recipAttrNames, j));
}
SET_VECTOR_ELT(newRecipAttrs, j, mkString("open"));
SET_STRING_ELT(newRecipAttrNames, j, mkChar("arrowtail"));
setAttrib(newRecipAttrs, R_NamesSymbol, newRecipAttrNames);
SET_SLOT(recipPE, Rf_install("attrs"), newRecipAttrs);
SET_VECTOR_ELT(peList, k, recipPE);
UNPROTECT(3);
}
UNPROTECT(1);
continue;
}
PROTECT(tmpToSTR = allocVector(STRSXP, 1));
PROTECT(curPE = NEW_OBJECT(peClass));
SET_SLOT(curPE, Rf_install("from"), curFrom);
SET_STRING_ELT(tmpToSTR, 0, toName);
SET_SLOT(curPE, Rf_install("to"), tmpToSTR);
if (strcmp(STR(edgeMode), "directed") == 0)
{
SET_VECTOR_ELT(curAttrs, 0, mkString("open"));
SET_VECTOR_ELT(curAttrs, 2, mkString("forward"));
}
else
{
SET_VECTOR_ELT(curAttrs, 0, mkString("none"));
SET_VECTOR_ELT(curAttrs, 2, mkString("none"));
}
PROTECT(tmpWtSTR = allocVector(STRSXP, 1));
PROTECT(tmpW = Rf_ScalarReal(REAL(curWeights)[y]));
SET_STRING_ELT(tmpWtSTR, 0, asChar(tmpW));
UNPROTECT(1);
SET_VECTOR_ELT(curAttrs, 1, tmpWtSTR);
SET_SLOT(curPE, Rf_install("attrs"), curAttrs);
SET_STRING_ELT(goodEdgeNames, curEle, mkChar(edgeName));
SET_VECTOR_ELT(peList, curEle, curPE);
curEle++;
for (i = 0; i < nSubG; i++) {
curSubG = getListElement(VECTOR_ELT(subGList, i), "graph");
subGEdgeL = GET_SLOT(curSubG, Rf_install("edgeL"));
subGNodes = GET_SLOT(curSubG, Rf_install("nodes"));
elt = getListElement(subGEdgeL, STR(curFrom));
if (elt == R_NilValue)
continue;
/* Extract out the edges */
subGEdges = VECTOR_ELT(elt, 0);
for (j = 0; j < length(subGEdges); j++) {
int subGIdx = INTEGER(subGEdges)[j]-1;
int graphIdx = INTEGER(curTo)[y]-1;
if(strcmp(CHAR(STRING_ELT(subGNodes, subGIdx)),CHAR(STRING_ELT(nodes, graphIdx))) == 0)
break;
}
if (j == length(subGEdges))
continue;
/* If we get here, then this edge is in subG 'i' */
SET_SLOT(curPE, Rf_install("subG"), Rf_ScalarInteger(i+1));
/* Only one subgraph per edge */
break;
}
free(edgeName);
UNPROTECT(4);
}
UNPROTECT(3);
}
setAttrib(peList, R_NamesSymbol, goodEdgeNames);
peList = assignAttrs(edgeAttrs, peList, defAttrs);
UNPROTECT(6);
return(peList);
}
SEXP new_posixt_object( double d){
SEXP x = PROTECT( Rf_ScalarReal( d ) ) ;
Rf_setAttrib(x, R_ClassSymbol, getPosixClasses() );
UNPROTECT(1);
return x ;
}
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;
}
SEXP emd_r(SEXP sBase, SEXP sCur, SEXP sExtra, SEXP sFlows, SEXP sDist, SEXP sMaxIter) {
SEXP sBaseDim = Rf_getAttrib(sBase, R_DimSymbol);
SEXP sCurDim = Rf_getAttrib(sCur, R_DimSymbol);
if (sBaseDim == R_NilValue || LENGTH(sBaseDim) != 2) Rf_error("base must be a matrix");
if (sCurDim == R_NilValue || LENGTH(sCurDim) != 2) Rf_error("cur must be a matrix");
int *baseDim = INTEGER(sBaseDim);
int *curDim = INTEGER(sCurDim);
int baseRows = baseDim[0], baseCol = baseDim[1];
int curRows = curDim[0], curCol = curDim[1];
int maxIter = Rf_asInteger(sMaxIter);
if (TYPEOF(sDist) != CLOSXP && (TYPEOF(sDist) != STRSXP || LENGTH(sDist) != 1)) Rf_error("invalid distance specification");
const char *distName = (TYPEOF(sDist) == STRSXP) ? CHAR(STRING_ELT(sDist, 0)) : 0;
dist_fn_t *dist_fn = 0;
if (!distName) {
dist_fn = calc_dist_default;
set_default_dist(eval_dist);
dist_clos = sDist;
cf1 = PROTECT(Rf_allocVector(REALSXP, FDIM));
cf2 = PROTECT(Rf_allocVector(REALSXP, FDIM));
} else {
if (!strcmp(distName, "euclidean")) dist_fn = calc_dist_L2;
if (!strcmp(distName, "manhattan")) dist_fn = calc_dist_L1;
}
if (!dist_fn)
Rf_error("invalid distance specification");
if (maxIter < 1) maxIter = 10000; /* somewhat random... */
sBase = Rf_coerceVector(sBase, REALSXP);
sCur = Rf_coerceVector(sCur, REALSXP);
double *baseVal = REAL(sBase);
double *curVal = REAL(sCur);
flow_t *flows = NULL;
int n_flows = 0;
if (baseCol != curCol) Rf_error("base and current sets must have the same dimensionality");
if (baseCol < 2) Rf_error("at least two columns (weight and location) are required");
if (baseCol > FDIM + 1) Rf_warning("more than %d dimensions are used, those will be ignored", FDIM);
signature_t baseSig, curSig;
baseSig.n = baseRows;
baseSig.Features = (feature_t*) R_alloc(baseRows, sizeof(feature_t));
baseSig.Weights = (float*) R_alloc(baseRows, sizeof(float));
curSig.n = curRows;
curSig.Features = (feature_t*) R_alloc(curRows, sizeof(feature_t));
curSig.Weights = (float*) R_alloc(curRows, sizeof(float));
int i, j;
for (i = 0; i < baseRows; i++) {
for (j = 0; j < FDIM; j++)
baseSig.Features[i].loc[j] = (j + 1 < baseCol) ? baseVal[i + (j + 1) * baseRows] : 0.0;
baseSig.Weights[i] = baseVal[i];
}
for (i = 0; i < curRows; i++) {
for (j = 0; j < FDIM; j++)
curSig.Features[i].loc[j] = (j + 1 < curCol) ? curVal[i + (j + 1) * curRows] : 0.0;
curSig.Weights[i] = curVal[i];
}
if (Rf_asLogical(sFlows) == TRUE) {
flows = malloc(sizeof(flow_t) * (baseRows + curRows - 1));
if (!flows)
Rf_error("unable to allocate memory for flows");
}
double d = emd_rubner(&baseSig, &curSig, flows, flows ? &n_flows : NULL, Rf_asInteger(sExtra), dist_fn, maxIter);
if (!distName) /* cf1, cf2 */
UNPROTECT(2);
if (!flows)
return Rf_ScalarReal(d);
SEXP res = PROTECT(Rf_ScalarReal(d));
SEXP fl = PROTECT(Rf_allocVector(VECSXP, 3)); /* must protect due to install() */
Rf_setAttrib(res, Rf_install("flows"), fl);
UNPROTECT(1);
SEXP f_from = Rf_allocVector(INTSXP, n_flows); SET_VECTOR_ELT(fl, 0, f_from);
SEXP f_to = Rf_allocVector(INTSXP, n_flows); SET_VECTOR_ELT(fl, 1, f_to);
SEXP f_amt = Rf_allocVector(REALSXP, n_flows); SET_VECTOR_ELT(fl, 2, f_amt);
int * i_from = INTEGER(f_from), * i_to = INTEGER(f_to);
double * r_amt = REAL(f_amt);
for (i = 0; i < n_flows; i++) {
i_from[i] = flows[i].from;
i_to[i] = flows[i].to;
r_amt[i] = flows[i].amount;
}
free(flows);
UNPROTECT(1);
return res;
}
SEXP new_date_object( double d){
SEXP x = PROTECT(Rf_ScalarReal( d ) ) ;
Rf_setAttrib(x, R_ClassSymbol, Rf_mkString("Date"));
UNPROTECT(1);
return x;
}
SEXP getEdgeLocs(Agraph_t *g) {
SEXP outList, curCP, curEP, pntList, pntSet, curXY, curLab;
SEXP epClass, cpClass, xyClass, labClass;
Agnode_t *node, *head;
Agedge_t *edge;
char *tmpString;
bezier bez;
int nodes;
int i,k,l,pntLstEl;
int curEle = 0;
epClass = MAKE_CLASS("AgEdge");
cpClass = MAKE_CLASS("BezierCurve");
xyClass = MAKE_CLASS("xyPoint");
labClass = MAKE_CLASS("AgTextLabel");
/* tmpString is used to convert a char to a char* w/ labels */
tmpString = (char *)R_alloc(2, sizeof(char));
if (tmpString == NULL) error("Allocation error in getEdgeLocs");
PROTECT(outList = allocVector(VECSXP, agnedges(g)));
nodes = agnnodes(g);
node = agfstnode(g);
for (i = 0; i < nodes; i++) {
edge = agfstout(g, node);
while (edge != NULL && edge->u.spl != NULL) {
PROTECT(curEP = NEW_OBJECT(epClass));
bez = edge->u.spl->list[0];
PROTECT(pntList = allocVector(VECSXP, ((bez.size-1)/3)));
pntLstEl = 0;
/* There are really (bez.size-1)/3 sets of control */
/* points, with the first set containing teh first 4 */
/* points, and then every other set starting with the */
/* last point from the previous set and then the next 3 */
for (k = 1; k < bez.size; k += 3) {
PROTECT(curCP = NEW_OBJECT(cpClass));
PROTECT(pntSet = allocVector(VECSXP, 4));
for (l = -1; l < 3; l++) {
PROTECT(curXY = NEW_OBJECT(xyClass));
SET_SLOT(curXY, Rf_install("x"), Rf_ScalarInteger(bez.list[k+l].x));
SET_SLOT(curXY, Rf_install("y"), Rf_ScalarInteger(bez.list[k+l].y));
SET_ELEMENT(pntSet, l+1, curXY);
UNPROTECT(1);
}
SET_SLOT(curCP, Rf_install("cPoints"), pntSet);
SET_ELEMENT(pntList, pntLstEl++, curCP);
UNPROTECT(2);
}
SET_SLOT(curEP, Rf_install("splines"), pntList);
/* get the sp and ep */
PROTECT(curXY = NEW_OBJECT(xyClass));
SET_SLOT(curXY, Rf_install("x"), Rf_ScalarInteger(bez.sp.x));
SET_SLOT(curXY, Rf_install("y"), Rf_ScalarInteger(bez.sp.y));
SET_SLOT(curEP, Rf_install("sp"), curXY);
UNPROTECT(1);
PROTECT(curXY = NEW_OBJECT(xyClass));
SET_SLOT(curXY, Rf_install("x"), Rf_ScalarInteger(bez.ep.x));
SET_SLOT(curXY, Rf_install("y"), Rf_ScalarInteger(bez.ep.y));
SET_SLOT(curEP, Rf_install("ep"), curXY);
UNPROTECT(1);
SET_SLOT(curEP, Rf_install("tail"), Rgraphviz_ScalarStringOrNull(node->name));
head = edge->head;
SET_SLOT(curEP, Rf_install("head"), Rgraphviz_ScalarStringOrNull(head->name));
/* TODO: clean up the use of attrs: dir, arrowhead, arrowtail.
* the following are for interactive plotting in R-env, not needed
* for output to files. The existing codes set "dir"-attr, but use
* "arrowhead"/"arrowtail" instead. Quite confusing.
*/
SET_SLOT(curEP, Rf_install("dir"), Rgraphviz_ScalarStringOrNull(agget(edge, "dir")));
SET_SLOT(curEP, Rf_install("arrowhead"), Rgraphviz_ScalarStringOrNull(agget(edge, "arrowhead")));
SET_SLOT(curEP, Rf_install("arrowtail"), Rgraphviz_ScalarStringOrNull(agget(edge, "arrowtail")));
SET_SLOT(curEP, Rf_install("arrowsize"), Rgraphviz_ScalarStringOrNull(agget(edge, "arrowsize")));
SET_SLOT(curEP, Rf_install("color"), Rgraphviz_ScalarStringOrNull(agget(edge, "color")));
/* get lty/lwd info */
if ( agget(edge, "lty") )
SET_SLOT(curEP, Rf_install("lty"), Rgraphviz_ScalarStringOrNull(agget(edge, "lty")));
if ( agget(edge, "lwd") )
SET_SLOT(curEP, Rf_install("lwd"), Rgraphviz_ScalarStringOrNull(agget(edge, "lwd")));
/* Get the label information */
if (edge->u.label != NULL) {
PROTECT(curLab = NEW_OBJECT(labClass));
SET_SLOT(curLab, Rf_install("labelText"),
Rgraphviz_ScalarStringOrNull(ED_label(edge)->text));
/* Get the X/Y location of the label */
PROTECT(curXY = NEW_OBJECT(xyClass));
#if GRAPHVIZ_MAJOR == 2 && GRAPHVIZ_MINOR > 20
SET_SLOT(curXY, Rf_install("x"), Rf_ScalarInteger(ED_label(edge)->pos.x));
SET_SLOT(curXY, Rf_install("y"), Rf_ScalarInteger(ED_label(edge)->pos.y));
#else
SET_SLOT(curXY, Rf_install("x"), Rf_ScalarInteger(edge->u.label->p.x));
SET_SLOT(curXY, Rf_install("y"), Rf_ScalarInteger(edge->u.label->p.y));
#endif
SET_SLOT(curLab, Rf_install("labelLoc"), curXY);
UNPROTECT(1);
snprintf(tmpString, 2, "%c",ED_label(edge)->u.txt.para->just);
SET_SLOT(curLab, Rf_install("labelJust"),
Rgraphviz_ScalarStringOrNull(tmpString));
SET_SLOT(curLab, Rf_install("labelWidth"),
Rf_ScalarInteger(ED_label(edge)->u.txt.para->width));
SET_SLOT(curLab, Rf_install("labelColor"),
Rgraphviz_ScalarStringOrNull(edge->u.label->fontcolor));
SET_SLOT(curLab, Rf_install("labelFontsize"), Rf_ScalarReal(edge->u.label->fontsize));
SET_SLOT(curEP, Rf_install("txtLabel"), curLab);
UNPROTECT(1);
}
SET_ELEMENT(outList, curEle++, curEP);
UNPROTECT(2);
edge = agnxtout(g, edge);
}
node = agnxtnode(g, node);
}
UNPROTECT(1);
return(outList);
}
