static SEXP graph_makeItem(SEXP s, int i)
{
if (s == R_NilValue)
return s;
else {
SEXP item = R_NilValue;/* -Wall */
switch (TYPEOF(s)) {
case STRSXP:
item = ScalarString(STRING_ELT(s, i));
break;
case EXPRSXP:
case VECSXP:
item = duplicate(VECTOR_ELT(s, i));
break;
case LGLSXP:
item = ScalarLogical(LOGICAL(s)[i]);
break;
case INTSXP:
item = ScalarInteger(INTEGER(s)[i]);
break;
case REALSXP:
item = ScalarReal(REAL(s)[i]);
break;
case CPLXSXP:
item = ScalarComplex(COMPLEX(s)[i]);
break;
case RAWSXP:
item = ScalarRaw(RAW(s)[i]);
break;
default:
error("unknown type");
}
return item;
}
}
SEXP attribute_hidden do_subset_dflt(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans, ax, px, x, subs;
int drop, i, nsubs, type;
/* By default we drop extents of length 1 */
/* Handle cases of extracting a single element from a simple vector
or matrix directly to improve speed for these simple cases. */
SEXP cdrArgs = CDR(args);
SEXP cddrArgs = CDR(cdrArgs);
if (cdrArgs != R_NilValue && cddrArgs == R_NilValue &&
TAG(cdrArgs) == R_NilValue) {
/* one index, not named */
SEXP x = CAR(args);
if (ATTRIB(x) == R_NilValue) {
SEXP s = CAR(cdrArgs);
R_xlen_t i = scalarIndex(s);
switch (TYPEOF(x)) {
case REALSXP:
if (i >= 1 && i <= XLENGTH(x))
return ScalarReal( REAL(x)[i-1] );
break;
case INTSXP:
if (i >= 1 && i <= XLENGTH(x))
return ScalarInteger( INTEGER(x)[i-1] );
break;
case LGLSXP:
if (i >= 1 && i <= XLENGTH(x))
return ScalarLogical( LOGICAL(x)[i-1] );
break;
// do the more rare cases as well, since we've already prepared everything:
case CPLXSXP:
if (i >= 1 && i <= XLENGTH(x))
return ScalarComplex( COMPLEX(x)[i-1] );
break;
case RAWSXP:
if (i >= 1 && i <= XLENGTH(x))
return ScalarRaw( RAW(x)[i-1] );
break;
default: break;
}
}
}
else if (cddrArgs != R_NilValue && CDR(cddrArgs) == R_NilValue &&
TAG(cdrArgs) == R_NilValue && TAG(cddrArgs) == R_NilValue) {
/* two indices, not named */
SEXP x = CAR(args);
SEXP attr = ATTRIB(x);
if (TAG(attr) == R_DimSymbol && CDR(attr) == R_NilValue) {
/* only attribute of x is 'dim' */
SEXP dim = CAR(attr);
if (TYPEOF(dim) == INTSXP && LENGTH(dim) == 2) {
/* x is a matrix */
SEXP si = CAR(cdrArgs);
SEXP sj = CAR(cddrArgs);
R_xlen_t i = scalarIndex(si);
R_xlen_t j = scalarIndex(sj);
int nrow = INTEGER(dim)[0];
int ncol = INTEGER(dim)[1];
if (i > 0 && j > 0 && i <= nrow && j <= ncol) {
/* indices are legal scalars */
R_xlen_t k = i - 1 + nrow * (j - 1);
switch (TYPEOF(x)) {
case REALSXP:
if (k < LENGTH(x))
return ScalarReal( REAL(x)[k] );
break;
case INTSXP:
if (k < LENGTH(x))
return ScalarInteger( INTEGER(x)[k] );
break;
case LGLSXP:
if (k < LENGTH(x))
return ScalarLogical( LOGICAL(x)[k] );
break;
case CPLXSXP:
if (k < LENGTH(x))
return ScalarComplex( COMPLEX(x)[k] );
break;
case RAWSXP:
if (k < LENGTH(x))
return ScalarRaw( RAW(x)[k] );
break;
default: break;
}
}
}
}
}
PROTECT(args);
drop = 1;
ExtractDropArg(args, &drop);
x = CAR(args);
/* This was intended for compatibility with S, */
/* but in fact S does not do this. */
/* FIXME: replace the test by isNull ... ? */
if (x == R_NilValue) {
UNPROTECT(1);
return x;
}
subs = CDR(args);
nsubs = length(subs); /* Will be short */
type = TYPEOF(x);
/* Here coerce pair-based objects into generic vectors. */
/* All subsetting takes place on the generic vector form. */
ax = x;
if (isVector(x))
PROTECT(ax);
else if (isPairList(x)) {
SEXP dim = getAttrib(x, R_DimSymbol);
int ndim = length(dim);
if (ndim > 1) {
PROTECT(ax = allocArray(VECSXP, dim));
setAttrib(ax, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol));
setAttrib(ax, R_NamesSymbol, getAttrib(x, R_DimNamesSymbol));
}
else {
PROTECT(ax = allocVector(VECSXP, length(x)));
setAttrib(ax, R_NamesSymbol, getAttrib(x, R_NamesSymbol));
}
for(px = x, i = 0 ; px != R_NilValue ; px = CDR(px))
SET_VECTOR_ELT(ax, i++, CAR(px));
}
else errorcall(call, R_MSG_ob_nonsub, type2char(TYPEOF(x)));
/* This is the actual subsetting code. */
/* The separation of arrays and matrices is purely an optimization. */
if(nsubs < 2) {
SEXP dim = getAttrib(x, R_DimSymbol);
int ndim = length(dim);
PROTECT(ans = VectorSubset(ax, (nsubs == 1 ? CAR(subs) : R_MissingArg),
call));
/* one-dimensional arrays went through here, and they should
have their dimensions dropped only if the result has
length one and drop == TRUE
*/
if(ndim == 1) {
SEXP attr, attrib, nattrib;
int len = length(ans);
if(!drop || len > 1) {
// must grab these before the dim is set.
SEXP nm = PROTECT(getAttrib(ans, R_NamesSymbol));
PROTECT(attr = allocVector(INTSXP, 1));
INTEGER(attr)[0] = length(ans);
setAttrib(ans, R_DimSymbol, attr);
if((attrib = getAttrib(x, R_DimNamesSymbol)) != R_NilValue) {
/* reinstate dimnames, include names of dimnames */
PROTECT(nattrib = duplicate(attrib));
SET_VECTOR_ELT(nattrib, 0, nm);
setAttrib(ans, R_DimNamesSymbol, nattrib);
setAttrib(ans, R_NamesSymbol, R_NilValue);
UNPROTECT(1);
}
UNPROTECT(2);
}
}
} else {
if (nsubs != length(getAttrib(x, R_DimSymbol)))
errorcall(call, _("incorrect number of dimensions"));
if (nsubs == 2)
ans = MatrixSubset(ax, subs, call, drop);
else
ans = ArraySubset(ax, subs, call, drop);
PROTECT(ans);
}
/* Note: we do not coerce back to pair-based lists. */
/* They are "defunct" in this version of R. */
if (type == LANGSXP) {
ax = ans;
PROTECT(ans = allocList(LENGTH(ax)));
if ( LENGTH(ax) > 0 )
SET_TYPEOF(ans, LANGSXP);
for(px = ans, i = 0 ; px != R_NilValue ; px = CDR(px))
SETCAR(px, VECTOR_ELT(ax, i++));
setAttrib(ans, R_DimSymbol, getAttrib(ax, R_DimSymbol));
setAttrib(ans, R_DimNamesSymbol, getAttrib(ax, R_DimNamesSymbol));
setAttrib(ans, R_NamesSymbol, getAttrib(ax, R_NamesSymbol));
SET_NAMED(ans, NAMED(ax)); /* PR#7924 */
}
else {
PROTECT(ans);
}
if (ATTRIB(ans) != R_NilValue) { /* remove probably erroneous attr's */
setAttrib(ans, R_TspSymbol, R_NilValue);
#ifdef _S4_subsettable
if(!IS_S4_OBJECT(x))
#endif
setAttrib(ans, R_ClassSymbol, R_NilValue);
}
UNPROTECT(4);
return ans;
}
SEXP readAnalyzeHDR(SEXP filepath)
{
// read header file
const char * filename = CHAR(STRING_ELT(filepath, 0));
FILE * pfile = fopen(filename, "rb");
if ( pfile == NULL ) return R_NilValue;
struct dsr header;
fread(&header, sizeof(struct dsr), 1, pfile);
fclose(pfile);
// test endianness
SEXP endian;
PROTECT(endian = NEW_STRING(1));
if ( header.hk.sizeof_hdr == 348L )
{
SET_STRING_ELT(endian, 0, mkChar("native"));
} else {
SET_STRING_ELT(endian, 0, mkChar("swap"));
// swap_hdr(&header);
}
// assign header_key elements
SEXP hk, hk_names;
PROTECT(hk = NEW_LIST(3));
PROTECT(hk_names = NEW_STRING(3));
SET_VECTOR_ELT(hk, 0, ScalarInteger(header.hk.sizeof_hdr));
SET_STRING_ELT(hk_names, 0, mkChar("sizeof_hdr"));
SET_VECTOR_ELT(hk, 1, ScalarInteger(header.hk.extents));
SET_STRING_ELT(hk_names, 1, mkChar("extents"));
SET_VECTOR_ELT(hk, 2, ScalarRaw(header.hk.regular));
SET_STRING_ELT(hk_names, 2, mkChar("regular"));
setAttrib(hk, R_NamesSymbol, hk_names);
// prepare dim and pixdim for image_dimension
SEXP dim, pixdim;
PROTECT(dim = NEW_INTEGER(8));
PROTECT(pixdim = NEW_NUMERIC(8));
for ( int i = 0; i < 8; i++ ) {
INTEGER(dim)[i] = header.dime.dim[i];
REAL(pixdim)[i] = header.dime.pixdim[i];
}
// assign image_dimension elements
SEXP dime, dime_names;
PROTECT(dime = NEW_LIST(11));
PROTECT(dime_names = NEW_STRING(11));
SET_VECTOR_ELT(dime, 0, dim);
SET_STRING_ELT(dime_names, 0, mkChar("dim"));
SET_VECTOR_ELT(dime, 1, ScalarInteger(header.dime.datatype));
SET_STRING_ELT(dime_names, 1, mkChar("datatype"));
SET_VECTOR_ELT(dime, 2, ScalarInteger(header.dime.bitpix));
SET_STRING_ELT(dime_names, 2, mkChar("bitpix"));
SET_VECTOR_ELT(dime, 3, pixdim);
SET_STRING_ELT(dime_names, 3, mkChar("pixdim"));
SET_VECTOR_ELT(dime, 4, ScalarReal(header.dime.vox_offset));
SET_STRING_ELT(dime_names, 4, mkChar("vox_offset"));
SET_VECTOR_ELT(dime, 5, ScalarReal(header.dime.cal_max));
SET_STRING_ELT(dime_names, 5, mkChar("cal_max"));
SET_VECTOR_ELT(dime, 6, ScalarReal(header.dime.cal_min));
SET_STRING_ELT(dime_names, 6, mkChar("cal_min"));
SET_VECTOR_ELT(dime, 7, ScalarReal(header.dime.compressed));
SET_STRING_ELT(dime_names, 7, mkChar("compressed"));
SET_VECTOR_ELT(dime, 8, ScalarReal(header.dime.verified));
SET_STRING_ELT(dime_names, 8, mkChar("verified"));
SET_VECTOR_ELT(dime, 9, ScalarReal(header.dime.glmax));
SET_STRING_ELT(dime_names, 9, mkChar("glmax"));
SET_VECTOR_ELT(dime, 10, ScalarReal(header.dime.glmin));
SET_STRING_ELT(dime_names, 10, mkChar("glmin"));
setAttrib(dime, R_NamesSymbol, dime_names);
// assign data_history elements
SEXP hist, hist_names;
PROTECT(hist = NEW_LIST(1));
PROTECT(hist_names = NEW_STRING(1));
SET_VECTOR_ELT(hist, 0, ScalarRaw(header.hist.orient));
SET_STRING_ELT(hist_names, 0, mkChar("orient"));
setAttrib(hist, R_NamesSymbol, hist_names);
// assign substructures into single list
SEXP outlist, outlist_names;
PROTECT(outlist = NEW_LIST(3));
PROTECT(outlist_names = NEW_STRING(3));
SET_VECTOR_ELT(outlist, 0, hk);
SET_STRING_ELT(outlist_names, 0, mkChar("hk"));
SET_VECTOR_ELT(outlist, 1, dime);
SET_STRING_ELT(outlist_names, 1, mkChar("dime"));
SET_VECTOR_ELT(outlist, 2, hist);
SET_STRING_ELT(outlist_names, 2, mkChar("hist"));
setAttrib(outlist, R_NamesSymbol, outlist_names);
setAttrib(outlist, install("endian"), endian);
// clean up and return
UNPROTECT(11);
return outlist;
}
SEXP to_sexp(QVariant variant) {
SEXP ans = NULL;
switch(variant.type()) {
case QMetaType::Void:
ans = R_NilValue;
break;
case QMetaType::UChar:
ans = ScalarRaw(variant.value<unsigned char>());
break;
case QMetaType::Bool:
ans = ScalarLogical(variant.value<bool>());
break;
case QMetaType::Int:
case QMetaType::UInt:
case QMetaType::Long:
case QMetaType::Short:
case QMetaType::UShort:
ans = ScalarInteger(variant.value<int>());
break;
case QMetaType::Double:
case QMetaType::LongLong:
case QMetaType::ULong:
case QMetaType::ULongLong:
case QMetaType::Float:
ans = ScalarReal(variant.value<double>());
break;
case QMetaType::QChar:
case QMetaType::Char:
case QMetaType::QString:
ans = qstring2sexp(variant.value<QString>());
break;
case QMetaType::QByteArray:
ans = to_sexp(variant.value<QByteArray>());
break;
case QMetaType::VoidStar:
ans = wrapPointer(variant.value<void *>());
break;
case QMetaType::QObjectStar:
ans = ptr_to_sexp(variant.value<QObject *>(),
SmokeType(qt_Smoke, "QObject"));
break;
case QMetaType::QWidgetStar:
ans = ptr_to_sexp(variant.value<QWidget *>(),
SmokeType(qt_Smoke, "QWidget"));
break;
case QMetaType::QCursor:
ans = QVARIANT_TO_SEXP(variant, QCursor);
break;
case QMetaType::QDate:
ans = QVARIANT_TO_SEXP(variant, QDate);
break;
case QMetaType::QSize:
ans = QVARIANT_TO_SEXP(variant, QSize);
case QMetaType::QSizeF:
ans = QVARIANT_TO_SEXP(variant, QSizeF);
break;
case QMetaType::QTime:
ans = QVARIANT_TO_SEXP(variant, QTime);
break;
case QMetaType::QVariantList:
ans = to_sexp(variant.value<QVariantList>(),
SmokeType(qt_Smoke, "QList<QVariant>"));
break;
case QMetaType::QPolygon:
ans = QVARIANT_TO_SEXP(variant, QPolygon);
break;
case QMetaType::QColor:
ans = QVARIANT_TO_SEXP(variant, QColor);
break;
case QMetaType::QRectF:
ans = QVARIANT_TO_SEXP(variant, QRectF);
break;
case QMetaType::QRect:
ans = QVARIANT_TO_SEXP(variant, QRect);
break;
case QMetaType::QLine:
ans = QVARIANT_TO_SEXP(variant, QLine);
break;
case QMetaType::QTextLength:
ans = QVARIANT_TO_SEXP(variant, QTextLength);
break;
case QMetaType::QStringList:
ans = to_sexp(variant.value<QStringList>(),
SmokeType(qt_Smoke, "QStringList"));
break;
case QMetaType::QVariantMap:
ans = to_sexp(variant.value<QVariantMap>(),
SmokeType(qt_Smoke, "QMap<QString,QVariant>"));
break;
case QMetaType::QVariantHash:
ans = to_sexp(variant.value<QVariantHash>(),
SmokeType(qt_Smoke, "QHash<QString,QVariant>"));
break;
case QMetaType::QIcon:
ans = QVARIANT_TO_SEXP(variant, QIcon);
break;
case QMetaType::QPen:
ans = QVARIANT_TO_SEXP(variant, QPen);
break;
case QMetaType::QLineF:
ans = QVARIANT_TO_SEXP(variant, QLineF);
break;
case QMetaType::QTextFormat:
ans = QVARIANT_TO_SEXP(variant, QTextFormat);
break;
case QMetaType::QPoint:
ans = QVARIANT_TO_SEXP(variant, QPoint);
break;
case QMetaType::QPointF:
ans = QVARIANT_TO_SEXP(variant, QPointF);
break;
case QMetaType::QUrl:
ans = QVARIANT_TO_SEXP(variant, QUrl);
break;
case QMetaType::QRegExp:
ans = QVARIANT_TO_SEXP(variant, QRegExp);
break;
case QMetaType::QDateTime:
ans = QVARIANT_TO_SEXP(variant, QDateTime);
break;
case QMetaType::QPalette:
ans = QVARIANT_TO_SEXP(variant, QPalette);
break;
case QMetaType::QFont:
ans = QVARIANT_TO_SEXP(variant, QFont);
break;
case QMetaType::QBrush:
ans = QVARIANT_TO_SEXP(variant, QBrush);
break;
case QMetaType::QRegion:
ans = QVARIANT_TO_SEXP(variant, QRegion);
break;
case QMetaType::QBitArray:
ans = QVARIANT_TO_SEXP(variant, QBitArray);
break;
case QMetaType::QImage:
ans = QVARIANT_TO_SEXP(variant, QImage);
break;
case QMetaType::QKeySequence:
ans = QVARIANT_TO_SEXP(variant, QKeySequence);
break;
case QMetaType::QSizePolicy:
ans = QVARIANT_TO_SEXP(variant, QSizePolicy);
break;
case QMetaType::QPixmap:
ans = QVARIANT_TO_SEXP(variant, QPixmap);
break;
case QMetaType::QLocale:
ans = QVARIANT_TO_SEXP(variant, QLocale);
break;
case QMetaType::QBitmap:
ans = QVARIANT_TO_SEXP(variant, QBitmap);
break;
case QMetaType::QMatrix: /* obsolete */
ans = QVARIANT_TO_SEXP(variant, QMatrix);
break;
#if QT_VERSION >= 0x40300
case QMetaType::QTransform:
ans = QVARIANT_TO_SEXP(variant, QTransform);
break;
#endif
#if QT_VERSION >= 0x40600
case QMetaType::QMatrix4x4:
ans = QVARIANT_TO_SEXP(variant, QMatrix4x4);
break;
case QMetaType::QVector2D:
ans = QVARIANT_TO_SEXP(variant, QVector2D);
break;
case QMetaType::QVector3D:
ans = QVARIANT_TO_SEXP(variant, QVector3D);
break;
case QMetaType::QVector4D:
ans = QVARIANT_TO_SEXP(variant, QVector4D);
break;
case QMetaType::QQuaternion:
ans = QVARIANT_TO_SEXP(variant, QQuaternion);
break;
#endif
case QMetaType::User:
break;
default:
error("Converting from QVariant: unhandled Qt type");
}
if (!ans)
error("Converting from QVariant: Qt type not yet implemented");
return ans;
}
