Esempio n. 1
0
Factor::Factor(SEXP fac) {
    Rcpp::RObject x = Rcpp::RObject(fac);
    SEXP classAttr = x.attr("class");
    std::string className;
    if(classAttr != R_NilValue)
	className = Rcpp::as<std::string>(classAttr);
    if(className != "factor")
	throw std::range_error("Invalid SEXP in Factor constructor");
    levelNames = Rcpp::as<std::vector<std::string> >(x.attr("levels"));
    int nObs = Rf_length(fac);
    observations.resize(nObs);
    int *ip = INTEGER(fac);
    for(int j=0; j < nObs; ++j)
	observations[j] = ip[j]-1;
}
Esempio n. 2
0
SEXP collapsedList(Rcpp::List ll) {
    if (ll.length() == 0) return R_NilValue;
    Rcpp::List::iterator it = ll.begin(); 
    switch(TYPEOF(*it)) {
        case REALSXP: {
            Rcpp::NumericVector v(ll.begin(), ll.end());
            Rcpp::RObject ro = ll[0];
            if (ro.hasAttribute("class")) {
                Rcpp::CharacterVector cv = ro.attr("class");
                if ((cv.size() == 1) && std::string(cv[0]) == "Date") {
                    Rcpp::DateVector dv(v);
                    return dv;
                }
                if ((cv.size() == 2) && std::string(cv[1]) == "POSIXt") {
                    Rcpp::DatetimeVector dtv(v);
                    return dtv;
                }
            }
            return v;
            break;              // not reached ...
        }
        case INTSXP: {
            Rcpp::IntegerVector v(ll.begin(), ll.end());
            return v;
            break;              // not reached ...
        }
        case LGLSXP: {
            Rcpp::LogicalVector v(ll.begin(), ll.end());
            return v;
            break;              // not reached ...
        }
        case STRSXP: {              // minor code smell that this is different :-/
            int n = ll.size();
            Rcpp::CharacterVector v(n);
            for (int i=0; i<n; i++) {
                std::string s = Rcpp::as<std::string>(ll[i]);
                v[i] = s;
            }
            return v;
            break;              // not reached ...
        }
    }
    return ll;
}
void graphConvert(SEXP graph_sexp, residualConnectivity::context::inputGraph& boostGraph, std::vector<residualConnectivity::context::vertexPosition>& vertexCoordinates)
{
	Rcpp::RObject graph = Rcpp::as<Rcpp::RObject>(graph_sexp);
	std::string className = Rcpp::as<std::string>(graph.attr("class"));
	Rcpp::NumericMatrix vertexCoordinates_matrix;
	if(className == "igraph")
	{
		Rcpp::Environment igraphEnv("package:igraph");
		Rcpp::Function isDirected = igraphEnv["is_directed"];
		if(Rcpp::as<bool>(isDirected(graph)))
		{
			throw std::runtime_error("Input `graph' must be undirected");
		}
		Rcpp::Function layoutAuto = igraphEnv["layout.auto"];
		vertexCoordinates_matrix = layoutAuto(graph);
		igraphConvert(graph_sexp, boostGraph);
	}
	else if(className == "graphNEL" || className == "graphAM")
	{
		Rcpp::S4 graphS4 = Rcpp::as<Rcpp::S4>(graph);
		Rcpp::S4 renderInfo = Rcpp::as<Rcpp::S4>(graphS4.slot("renderInfo"));
		Rcpp::List nodes = Rcpp::as<Rcpp::List>(renderInfo.slot("nodes"));
		Rcpp::Function length("length"), cbind("cbind");
		if(Rcpp::as<int>(length(nodes)) > 0)
		{
			vertexCoordinates_matrix = Rcpp::as<Rcpp::NumericMatrix>(cbind(nodes["nodeX"], nodes["nodeY"]));
		}
		if(className == "graphNEL") graphNELConvert(graph_sexp, boostGraph);
		else graphAMConvert(graph_sexp, boostGraph);
	}
	else
	{
		throw std::runtime_error("Input graph must have class \"igraph\", \"graphAM\" or \"graphNEL\"");
	}
	std::size_t nVertexCoordinates = vertexCoordinates_matrix.nrow();
	vertexCoordinates.clear();
	vertexCoordinates.reserve(nVertexCoordinates);
	for(std::size_t i = 0; i < nVertexCoordinates; i++)
	{
		vertexCoordinates.push_back(residualConnectivity::context::vertexPosition((residualConnectivity::context::vertexPosition::first_type)vertexCoordinates_matrix((int)i, 0), (residualConnectivity::context::vertexPosition::second_type)vertexCoordinates_matrix((int)i, 1)));
	}
}
Esempio n. 4
0
SEXP dataframe_to_list(SEXP _source, SEXP _nrow, SEXP _ncol, SEXP _dest){
	Rcpp::DataFrame source = Rcpp::DataFrame(_source);
	Rcpp::GenericVector dest = Rcpp::GenericVector(_dest);
	int nrow = Rcpp::as<int>(_nrow);
	int ncol = Rcpp::as<int>(_ncol);	
	for (int j = 0; j < ncol; j ++){
		Rcpp::RObject robj = source[j];
		switch(robj.sexp_type()) {
			case RAWSXP: {
				Rcpp::RawVector z = source[j]; 
				for (int i = 0; i < nrow; i ++) {
					Rcpp::List l = dest[i];
					l[j] = Rcpp::wrap(z[i]);}}
			break;
			case STRSXP: {
				Rcpp::CharacterVector z = source[j]; 
				for (int i = 0; i < nrow; i ++) {
					Rcpp::List l = dest[i];
					l[j] = Rcpp::wrap(z[i]);}}
			break;
			case LGLSXP: {
				Rcpp::LogicalVector z = source[j]; 
				for (int i = 0; i < nrow; i ++) {
					Rcpp::List l = dest[i];
					l[j] = Rcpp::wrap(z[i]);}}
			break;
			case REALSXP: {
				Rcpp::NumericVector z = source[j]; 
				for (int i = 0; i < nrow; i ++) {
					Rcpp::List l = dest[i];
					l[j] = Rcpp::wrap(z[i]);}}
			break;
			case INTSXP: {
				Rcpp::IntegerVector z = source[j]; 
				for (int i = 0; i < nrow; i ++) {
					Rcpp::List l = dest[i];
					l[j] = Rcpp::wrap(z[i]);}}
			break;
			default: {
				throw UnsupportedType(robj.sexp_type());}}}
	return Rcpp::wrap(_dest);}
Esempio n. 5
0
Rcpp::IntegerVector process_subset_vector(Rcpp::RObject subset, int upper, bool zero_indexed) {
    if (subset.sexp_type()!=INTSXP) { 
        throw std::runtime_error("subset vector must be an integer vector");
    }  
    Rcpp::IntegerVector sout(subset);

    if (!zero_indexed) {
        sout=Rcpp::clone(sout);
        for (auto& s : sout) { --s; }
    }

    for (auto sIt=sout.begin(); sIt!=sout.end(); ++sIt) {
        if (*sIt < 0 || *sIt >= upper) { 
            throw std::runtime_error("subset indices out of range");
        }
    }
    return sout;
}
Esempio n. 6
0
SEXP hclustCombinedMatrix(SEXP mpcrossRF_, SEXP preClusterResults_)
{
BEGIN_RCPP
	bool noDuplicates;
	R_xlen_t preClusterMarkers = countPreClusterMarkers(preClusterResults_, noDuplicates);
	if(!noDuplicates)
	{
		throw std::runtime_error("Duplicate marker indices in call to hclustThetaMatrix");
	}

	Rcpp::List preClusterResults = preClusterResults_;
	Rcpp::S4 mpcrossRF = mpcrossRF_;
	Rcpp::S4 rf = mpcrossRF.slot("rf");

	Rcpp::RObject lodObject = rf.slot("lod");
	if(lodObject.isNULL())
	{
		throw std::runtime_error("Slot mpcrossRF@rf@lod cannot be NULL if clusterBy is equal to \"combined\"");
	}
	Rcpp::S4 lod = Rcpp::as<Rcpp::S4>(lodObject);
	Rcpp::S4 theta = rf.slot("theta");
	Rcpp::RawVector data = theta.slot("data");
	Rcpp::NumericVector levels = theta.slot("levels");
	Rcpp::CharacterVector markers = theta.slot("markers");
	Rcpp::NumericVector lodData = lod.slot("x");
	if(markers.size() != preClusterMarkers || lodData.size() != (preClusterMarkers*(preClusterMarkers+(R_xlen_t)1))/(R_xlen_t)2)
	{
		throw std::runtime_error("Number of markers in precluster object was inconsistent with number of markers in mpcrossRF object");
	}
	R_xlen_t resultDimension = preClusterResults.size();
	//Work out minimum difference between recombination levels
	double minDifference = 1;
	for(int i = 0; i < levels.size()-1; i++)
	{
		minDifference = std::min(minDifference, levels[i+1] - levels[i]);
	}
	double maxLod = *std::max_element(lodData.begin(), lodData.end());
	double lodMultiplier = minDifference/maxLod;
	//Allocate enough storage. This symmetric matrix stores the *LOWER* triangular part, in column-major storage. Excluding the diagonal. 
	Rcpp::NumericVector result(((resultDimension-(R_xlen_t)1)*resultDimension)/(R_xlen_t)2);
	for(R_xlen_t column = 0; column < resultDimension; column++)
	{
		Rcpp::IntegerVector columnMarkers = preClusterResults(column);
		for(R_xlen_t row = column + (R_xlen_t)1; row < resultDimension; row++)
		{
			Rcpp::IntegerVector rowMarkers = preClusterResults(row);
			double total = 0;
			R_xlen_t counter = 0;
			for(int columnMarkerCounter = 0; columnMarkerCounter < columnMarkers.size(); columnMarkerCounter++)
			{
				R_xlen_t marker1 = columnMarkers[columnMarkerCounter]-(R_xlen_t)1;
				for(int rowMarkerCounter = 0; rowMarkerCounter < rowMarkers.size(); rowMarkerCounter++)
				{
					R_xlen_t marker2 = rowMarkers[rowMarkerCounter]-(R_xlen_t)1;
					R_xlen_t column = std::max(marker1, marker2);
					R_xlen_t row = std::min(marker1, marker2);
					Rbyte thetaDataValue = data((column*(column+(R_xlen_t)1))/(R_xlen_t)2 + row);
					double currentLodDataValue = lodData((column*(column+(R_xlen_t)1))/(R_xlen_t)2 + row);
					if(thetaDataValue != 0xFF && currentLodDataValue != NA_REAL && currentLodDataValue == currentLodDataValue)
					{
						total += levels(thetaDataValue) + (maxLod - currentLodDataValue) *lodMultiplier;
						counter++;
					}
				}
			}
			if(counter == 0) total = 0.5 + minDifference;
			else total /= counter;
			result(((resultDimension-1)*resultDimension)/(R_xlen_t)2 - ((resultDimension - column)*(resultDimension-column-(R_xlen_t)1))/(R_xlen_t)2 + row-column-(R_xlen_t)1) = total;
		}
	}
	return result;
END_RCPP
}
Esempio n. 7
0
SEXP hclustLodMatrix(SEXP mpcrossRF_, SEXP preClusterResults_)
{
BEGIN_RCPP
	bool noDuplicates;
	R_xlen_t preClusterMarkers = countPreClusterMarkers(preClusterResults_, noDuplicates);
	if(!noDuplicates)
	{
		throw std::runtime_error("Duplicate marker indices in call to hclustThetaMatrix");
	}

	Rcpp::List preClusterResults = preClusterResults_;
	Rcpp::S4 mpcrossRF = mpcrossRF_;
	Rcpp::S4 rf = mpcrossRF.slot("rf");

	Rcpp::RObject lodObject = rf.slot("lod");
	if(lodObject.isNULL())
	{
		throw std::runtime_error("Slot mpcrossRF@rf@lod cannot be NULL if clusterBy is equal to \"combined\"");
	}
	Rcpp::S4 lod = Rcpp::as<Rcpp::S4>(lodObject);
	Rcpp::NumericVector lodData = lod.slot("x");
	if(lodData.size() != (preClusterMarkers*(preClusterMarkers+(R_xlen_t)1))/(R_xlen_t)2)
	{
		throw std::runtime_error("Number of markers in precluster object was inconsistent with number of markers in mpcrossRF object");
	}
	R_xlen_t resultDimension = preClusterResults.size();
	double maxLod = *std::max_element(lodData.begin(), lodData.end());
	//Allocate enough storage. This symmetric matrix stores the *LOWER* triangular part, in column-major storage. Excluding the diagonal. 
	Rcpp::NumericVector result(((resultDimension-(R_xlen_t)1)*resultDimension)/(R_xlen_t)2);
	for(R_xlen_t column = 0; column < resultDimension; column++)
	{
		Rcpp::IntegerVector columnMarkers = preClusterResults(column);
		for(R_xlen_t row = column + 1; row < resultDimension; row++)
		{
			Rcpp::IntegerVector rowMarkers = preClusterResults(row);
			double total = 0;
			int counter = 0;
			for(R_xlen_t columnMarkerCounter = 0; columnMarkerCounter < columnMarkers.size(); columnMarkerCounter++)
			{
				R_xlen_t marker1 = columnMarkers[columnMarkerCounter]-(R_xlen_t)1;
				for(R_xlen_t rowMarkerCounter = 0; rowMarkerCounter < rowMarkers.size(); rowMarkerCounter++)
				{
					R_xlen_t marker2 = rowMarkers[rowMarkerCounter]-(R_xlen_t)1;
					R_xlen_t column = std::max(marker1, marker2);
					R_xlen_t row = std::min(marker1, marker2);
					double currentLodDataValue = lodData((column*(column+(R_xlen_t)1))/(R_xlen_t)2 + row);
					if(currentLodDataValue != NA_REAL && currentLodDataValue == currentLodDataValue)
					{
						total += currentLodDataValue;
						counter++;
					}
				}
			}
			if(counter == 0) total = maxLod;
			else total /= counter;
			result(((resultDimension-(R_xlen_t)1)*resultDimension)/(R_xlen_t)2 - ((resultDimension - column)*(resultDimension-column-(R_xlen_t)1))/(R_xlen_t)2 + row-column-(R_xlen_t)1) = maxLod - total;
		}
	}
	return result;
END_RCPP;
}