Esempio n. 1
0
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;
    }
}
Esempio n. 2
0
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;
}
Esempio n. 3
0
	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;
	}
Esempio n. 4
0
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;
}