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;
}
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)));
}
}
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);}
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;
}
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
}
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;
}