// [[Rcpp::export]] Rcpp::RawVector magick_image_write( XPtrImage input, Rcpp::CharacterVector format, Rcpp::IntegerVector quality, Rcpp::IntegerVector depth, Rcpp::CharacterVector density, Rcpp::CharacterVector comment){ if(!input->size()) return Rcpp::RawVector(0); XPtrImage image = copy(input); #if MagickLibVersion >= 0x691 //suppress write warnings see #74 and #116 image->front().quiet(true); #endif if(format.size()) for_each ( image->begin(), image->end(), Magick::magickImage(std::string(format[0]))); if(quality.size()) for_each ( image->begin(), image->end(), Magick::qualityImage(quality[0])); if(depth.size()) for_each ( image->begin(), image->end(), Magick::depthImage(depth[0])); if(density.size()){ for_each ( image->begin(), image->end(), Magick::resolutionUnitsImage(Magick::PixelsPerInchResolution)); for_each ( image->begin(), image->end(), Magick::densityImage(Point(density[0]))); } if(comment.size()) for_each ( image->begin(), image->end(), Magick::commentImage(std::string(comment.at(0)))); Magick::Blob output; writeImages( image->begin(), image->end(), &output ); Rcpp::RawVector res(output.length()); std::memcpy(res.begin(), output.data(), output.length()); return res; }
SEXP rawSymmetricMatrixToDist(SEXP object) { BEGIN_RCPP Rcpp::S4 rawSymmetric = object; Rcpp::NumericVector levels = Rcpp::as<Rcpp::NumericVector>(rawSymmetric.slot("levels")); Rcpp::CharacterVector markers = Rcpp::as<Rcpp::CharacterVector>(rawSymmetric.slot("markers")); Rcpp::RawVector data = Rcpp::as<Rcpp::RawVector>(rawSymmetric.slot("data")); R_xlen_t size = markers.size(), levelsSize = levels.size(); Rcpp::NumericVector result(size*(size - 1)/2, 0); int counter = 0; for(R_xlen_t row = 0; row < size; row++) { for(R_xlen_t column = row+1; column < size; column++) { int byte = data(column * (column + (R_xlen_t)1)/(R_xlen_t)2 + row); if(byte == 255) result(counter) = std::numeric_limits<double>::quiet_NaN(); else result(counter) = levels(byte); counter++; } } result.attr("Size") = (int)size; result.attr("Labels") = markers; result.attr("Diag") = false; result.attr("Upper") = false; result.attr("class") = "dist"; return result; END_RCPP }
//' @rdname convert //' @keywords internal manip // [[Rcpp::export]] Rcpp::List icd9ShortToPartsCpp(const Rcpp::CharacterVector icd9Short, const Rcpp::String minorEmpty) { Rcpp::CharacterVector major(icd9Short.size()); Rcpp::CharacterVector minor(icd9Short.size()); for (int i = 0; i < icd9Short.size(); ++i) { Rcpp::String thisShort = icd9Short[i]; if (thisShort == NA_STRING) { // .is_na() is private? minor[i] = NA_STRING; // I think set_na() might be an alternative. continue; } std::string s(thisShort.get_cstring()); // TODO maybe better to use as? s = strimCpp(s); // in place or rewrite? std::string::size_type sz = s.size(); if (icd9IsASingleE(s.c_str())) { // E code switch (sz) { case 2: case 3: case 4: major[i] = s.substr(0, sz); minor[i] = minorEmpty; break; case 5: major[i] = s.substr(0, 4); minor[i] = s.substr(4, 1); break; default: major[i] = NA_STRING; minor[i] = NA_STRING; continue; } } else { // not an E code switch (sz) { case 1: case 2: case 3: major[i] = s.substr(0, sz); minor[minorEmpty]; continue; case 4: case 5: major[i] = s.substr(0, 3); minor[i] = s.substr(3, sz - 3); continue; default: major[i] = NA_STRING; minor[i] = NA_STRING; continue; } } } // for return icd9MajMinToParts(icd9AddLeadingZeroesMajor(major), minor); }
SEXP hclustThetaMatrix(SEXP mpcrossRF_, SEXP preClusterResults_) { BEGIN_RCPP Rcpp::List preClusterResults = preClusterResults_; bool noDuplicates; R_xlen_t preClusterMarkers = countPreClusterMarkers(preClusterResults_, noDuplicates); if(!noDuplicates) { throw std::runtime_error("Duplicate marker indices in call to hclustThetaMatrix"); } Rcpp::S4 mpcrossRF = mpcrossRF_; Rcpp::S4 rf = mpcrossRF.slot("rf"); Rcpp::S4 theta = rf.slot("theta"); Rcpp::RawVector data = theta.slot("data"); Rcpp::NumericVector levels = theta.slot("levels"); Rcpp::CharacterVector markers = theta.slot("markers"); if(markers.size() != preClusterMarkers) { 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(); //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; R_xlen_t 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); Rbyte thetaDataValue = data((column*(column+(R_xlen_t)1))/(R_xlen_t)2 + row); if(thetaDataValue != 0xFF) { total += levels(thetaDataValue); counter++; } } } if(counter == 0) total = 0.5; 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) = total; } } return result; END_RCPP }
// [[Rcpp::export]] Rcpp::List CPL_sfc_from_wkt(Rcpp::CharacterVector wkt) { std::vector<OGRGeometry *> g(wkt.size()); OGRGeometryFactory f; for (int i = 0; i < wkt.size(); i++) { char *wkt_str = wkt(i); #if GDAL_VERSION_MAJOR <= 2 && GDAL_VERSION_MINOR <= 2 handle_error(f.createFromWkt(&wkt_str, NULL, &(g[i]))); #else handle_error(f.createFromWkt( (const char*) wkt_str, NULL, &(g[i]))); #endif } return sfc_from_ogr(g, true); }
SEXP constructDissimilarityMatrix(SEXP object, SEXP clusters_) { BEGIN_RCPP Rcpp::S4 rawSymmetric = object; Rcpp::NumericVector levels = Rcpp::as<Rcpp::NumericVector>(rawSymmetric.slot("levels")); Rcpp::CharacterVector markers = Rcpp::as<Rcpp::CharacterVector>(rawSymmetric.slot("markers")); Rcpp::RawVector data = Rcpp::as<Rcpp::RawVector>(rawSymmetric.slot("data")); int nMarkers = markers.size(); std::vector<double> levelsCopied = Rcpp::as<std::vector<double> >(levels); std::vector<int> permutation(nMarkers); for(int i = 0; i < nMarkers; i++) permutation[i] = i; return constructDissimilarityMatrixInternal(&(data(0)), levelsCopied, nMarkers, clusters_, 0, permutation); END_RCPP }
DataFrameJoinVisitors::DataFrameJoinVisitors(const Rcpp::DataFrame& left_, const Rcpp::DataFrame& right_, Rcpp::CharacterVector names_left, Rcpp::CharacterVector names_right, bool warn_ ) : left(left_), right(right_), visitor_names_left(names_left), visitor_names_right(names_right), nvisitors(names_left.size()), visitors(nvisitors), warn(warn_) { std::string name_left, name_right ; IntegerVector indices_left = Language( "match", names_left, RCPP_GET_NAMES(left) ).fast_eval() ; IntegerVector indices_right = Language( "match", names_right, RCPP_GET_NAMES(right) ).fast_eval() ; for( int i=0; i<nvisitors; i++){ name_left = names_left[i] ; name_right = names_right[i] ; if( indices_left[i] == NA_INTEGER ){ stop( "'%s' column not found in lhs, cannot join" ) ; } if( indices_right[i] == NA_INTEGER ){ stop( "'%s' column not found in rhs, cannot join" ) ; } visitors[i] = join_visitor( left[indices_left[i]-1], right[indices_right[i]-1], name_left, name_right, warn ) ; } }
std::vector<char *> create_options(Rcpp::CharacterVector lco, bool quiet) { if (lco.size() == 0) quiet = true; // nothing to report if (! quiet) Rcpp::Rcout << "options: "; // #nocov std::vector<char *> ret(lco.size() + 1); for (int i = 0; i < lco.size(); i++) { ret[i] = (char *) (lco[i]); if (! quiet) Rcpp::Rcout << ret[i] << " "; // #nocov } ret[lco.size()] = NULL; if (! quiet) Rcpp::Rcout << std::endl; // #nocov return ret; }
Rcpp::CharacterVector parse_gb_qualifiers( const std::vector<std::string>& qualifiers ) { int begin_, end_; std::vector<std::string> names, values; names.reserve( qualifiers.size() ); values.reserve( qualifiers.size() ); std::vector<std::string>::const_iterator s_it = std::begin(qualifiers); for ( ; s_it != std::end( qualifiers ); s_it++ ) { begin_ = s_it->find_first_not_of("="); end_ = s_it->find_first_of( "=", begin_ ); names.push_back( s_it->substr( begin_, end_ ) ); values.push_back( trim( s_it->substr(end_ + 1, s_it->length() - end_), "\"") ); } Rcpp::CharacterVector Values = Rcpp::CharacterVector( std::begin(values), std::end(values) ); Values.names() = names; return Values; }
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; }
// [[Rcpp::export]] XPtrImage magick_image_readbin(Rcpp::RawVector x, Rcpp::CharacterVector density, Rcpp::IntegerVector depth, bool strip = false){ XPtrImage image = create(); #if MagickLibVersion >= 0x689 Magick::ReadOptions opts = Magick::ReadOptions(); #if MagickLibVersion >= 0x690 opts.quiet(1); #endif if(density.size()) opts.density(std::string(density.at(0)).c_str()); if(depth.size()) opts.depth(depth.at(0)); Magick::readImages(image.get(), Magick::Blob(x.begin(), x.length()), opts); #else Magick::readImages(image.get(), Magick::Blob(x.begin(), x.length())); #endif if(strip) for_each (image->begin(), image->end(), Magick::stripImage()); return image; }
// [[Rcpp::export]] bool guessShortPlusFactorCpp(SEXP x_, int n) { Rcpp::CharacterVector x; switch(TYPEOF(x_)) { case STRSXP: { x = Rcpp::as<Rcpp::CharacterVector>(x_); break; } case INTSXP: { if (Rf_isFactor(x_)) x = Rf_getAttrib(x_, R_LevelsSymbol); break; } case LGLSXP: { // we will accept all logical values, if all are NA, which defauts to // logical unless otherwise specified. And we obviously don't know whether // these NAs would have been short or long, just default to short. Rcpp::LogicalVector xl = Rcpp::LogicalVector(x_); if (Rcpp::all(is_na(xl))) return true; // don't break, because if there were non-NA logicals, this is an error } default: { Rcpp::stop("Character vectors and factors are accepted"); } } n = std::min((int)x.length(), n); const char * b; const char * ob; Rcpp::String bs; for (R_xlen_t i = 0; i != n; ++i) { bs = x[i]; b = bs.get_cstring(); ob = b; while (*b) { if (*b == '.') return false; ++b; } // stop when we first get a five digit code. There are four digit major E codes. if ((b - ob) == 5) return true; } return true; }
// [[Rcpp::export]] XPtrImage magick_image_readpath(Rcpp::CharacterVector paths, Rcpp::CharacterVector density, Rcpp::IntegerVector depth, bool strip = false){ XPtrImage image = create(); #if MagickLibVersion >= 0x689 Magick::ReadOptions opts = Magick::ReadOptions(); #if MagickLibVersion >= 0x690 opts.quiet(1); #endif if(density.size()) opts.density(std::string(density.at(0)).c_str()); if(depth.size()) opts.depth(depth.at(0)); for(int i = 0; i < paths.size(); i++) Magick::readImages(image.get(), std::string(paths[i]), opts); #else for(int i = 0; i < paths.size(); i++) Magick::readImages(image.get(), std::string(paths[i])); #endif if(strip) for_each (image->begin(), image->end(), Magick::stripImage()); return image; }
//' @rdname convert //' @export // [[Rcpp::export]] Rcpp::CharacterVector icd9DecimalToShort( const Rcpp::CharacterVector icd9Decimal) { Rcpp::CharacterVector out = clone(icd9Decimal); // clone instead of pushing back thousands of times size_t ilen = icd9Decimal.length(); if (ilen == 0) return out; for (size_t i = 0; i != ilen; ++i) { Rcpp::String strna = icd9Decimal[i]; // need to copy here? does it copy? if (strna == NA_STRING || strna == "") continue; // TODO: Rcpp::String doesn't implement many functions, so using STL. A FAST way // might be to use Rcpp::String's function get_cstring, and recode the trim // functions to take const char *. This would avoid the type change AND be // faster trimming. const char * thiscode_cstr = strna.get_cstring(); std::string thiscode(thiscode_cstr); thiscode = trimLeftCpp(thiscode); // TODO consider rejecting grossly invalid codes as NA: std::size_t pos = thiscode.find_first_of("."); if (pos != std::string::npos) { #ifdef ICD9_DEBUG_TRACE Rcpp::Rcout << "found .\n"; #endif // now we assume that the major is snug against the left side, so we can add zero padding thiscode.erase(pos, 1); // remove the decimal point // could do fewer tests on the code by doing this last, but most codes are not V or E... if (pos > 0 && pos < 4 && !icd9IsASingleVE(thiscode_cstr)) { #ifdef ICD9_DEBUG_TRACE Rcpp::Rcout << "found numeric\n"; #endif thiscode.insert(0, 3 - pos, '0'); } else if (pos == 2 && icd9IsASingleV(thiscode_cstr)) { #ifdef ICD9_DEBUG_TRACE Rcpp::Rcout << "found V\n"; #endif thiscode.insert(1, 1, '0'); out[i] = thiscode; } else if ((pos == 2 || pos == 3) && icd9IsASingleE(thiscode_cstr)) { #ifdef ICD9_DEBUG_TRACE Rcpp::Rcout << "found E\n"; #endif thiscode.insert(1, 4 - pos, '0'); } // otherwise leave the code alone out[i] = thiscode; } else { out[i] = Rcpp::String(icd9AddLeadingZeroesMajorSingleStd(thiscode)); } } return out; }
void TimeSeriesPicker::on_buttonBox_accepted() { QStringList id; Rcpp::CharacterVector vec = vv->getCharacterVector(vv->getVariableIndex(ui->comboBoxVariableID->currentText())); for (int i = 0; i < vec.length(); ++i) { id << QString::fromUtf8(vec[i]); } id.removeDuplicates(); if (id.length() != vec.length()) { QMessageBox::information(this,"Non ID Variable Selected","Please Choose unique variable for ID"); return; } if (ui->listWidgetTimes->selectedItems().length() < 2) { QMessageBox::information(this,"No Selected time","Please Choose at least two time"); return; } QStringList timeList; for (int i = 0; i < ui->listWidgetTimes->count(); ++i) { if (ui->listWidgetTimes->item(i)->isSelected()) { timeList << ui->listWidgetTimes->item(i)->text(); } } QString x = ui->comboBoxVariable->currentText(); vv->sendDataFrameSeriesFormatted(ui->comboBoxVariable->currentText(),ui->comboBoxVariableID->currentText(),timeList,rconn); setupChartView("Time Series Plot",x, new QWidget()); QString command; try { command = QString("gr<-ggplot(dframe, aes(times, %1 , group = ID, colour = ID)) + geom_line()").arg(x); qDebug() << command; rconn.parseEvalQ(command.toStdString()); printGraph(rconn,11,6); } catch (...) { } close(); }
void mdDataSetGetNames(Rcpp::CharacterVector &names, ns4__Axes *axes, int i, bool isRow) { int axis; if (isRow) axis = 1; else axis = 0; std::string name = ""; std::vector<ns4__Member *> memberList = axes->Axis[axis]->__union_Axis->Tuples->Tuple[i]->Member; for (int j = 0; j < memberList.size(); j++) { name = name + *memberList[j]->Caption + ", "; } names.push_back(name.substr(0, name.size() - 2)); }
//' @rdname convert //' @keywords internal manip // [[Rcpp::export]] Rcpp::List icd9DecimalToPartsCpp(const Rcpp::CharacterVector icd9Decimal, const Rcpp::String minorEmpty) { Rcpp::CharacterVector majors; Rcpp::CharacterVector minors; int ilen = icd9Decimal.length(); if (ilen == 0) { return Rcpp::List::create(Rcpp::_["major"] = Rcpp::CharacterVector::create(), Rcpp::_["minor"] = Rcpp::CharacterVector::create()); } for (Rcpp::CharacterVector::const_iterator it = icd9Decimal.begin(); it != icd9Decimal.end(); ++it) { Rcpp::String strna = *it; if (strna == NA_STRING || strna == "") { majors.push_back(NA_STRING); minors.push_back(NA_STRING); continue; } // TODO: Rcpp::Rcpp::String doesn't implement many functions, so using STL. A FAST way // would be to use Rcpp::String's function get_cstring, and recode the trim // functions to take const char *. This would avoid the type change AND be // faster trimming. std::string thiscode = Rcpp::as<std::string>(*it); thiscode = strimCpp(thiscode); // This updates 'thisccode' by reference, no copy std::size_t pos = thiscode.find("."); // substring parts std::string majorin; Rcpp::String minorout; if (pos != std::string::npos) { majorin = thiscode.substr(0, pos); minorout = thiscode.substr(pos + 1); } else { majorin = thiscode; minorout = minorEmpty; } majors.push_back(icd9AddLeadingZeroesMajorSingle(majorin)); minors.push_back(minorout); } return Rcpp::List::create(Rcpp::_["major"] = majors, Rcpp::_["minor"] = minors); }
void rowSetParseData(std::vector<char *> rows, Rcpp::DataFrame *resultDataFrame, char *colName, bool isChar) { rapidxml::xml_document<> data; std::string xmlWrapper; char *xmlRow; int textLength; char *parseText; Rcpp::CharacterVector dimension; Rcpp::NumericVector dataColumn; for (int row = 0; row < rows.size(); row++) { bool found = false; xmlWrapper = "<row>"; xmlWrapper = xmlWrapper + rows[row] + "</row>"; xmlRow = strdup(xmlWrapper.c_str()); textLength = strlen(xmlRow); parseText = new char[textLength+1]; parseText = strcpy(parseText, xmlRow); data.parse<0>(parseText); rapidxml::xml_node<char> *rowData = data.first_node()->first_node(colName); if (rowData != NULL) { if (isChar) dimension.push_back(rowData->value()); else dataColumn.push_back(atof(rowData->value())); found = true; } if (!found && isChar) dimension.push_back(NA_STRING); else if (!found && !isChar) dataColumn.push_back(NA_REAL); } if (isChar) resultDataFrame->push_back(dimension); else resultDataFrame->push_back(dataColumn); }
// [[Rcpp::export]] Rcpp::CharacterVector icd9MajMinToShort(const Rcpp::CharacterVector major, const Rcpp::CharacterVector minor) { #ifdef ICD9_DEBUG_TRACE Rcpp::Rcout << "icd9MajMinToShort: major.size() = " << major.size() << " and minor.size() = " << minor.size() << "\n"; #endif if ((major.size() != 1 && major.size() != minor.size()) || (major.size() == 1 && minor.size() == 0)) { Rcpp::stop( "icd9MajMinToShort, length of majors and minors must be equal, unless majors length is one."); } if (major.size() == 1) { #ifdef ICD9_DEBUG_TRACE Rcpp::Rcout << "icd9MajMinToShort: major.size() = 1\n"; #endif Rcpp::CharacterVector newmajor(minor.size(), major[0]); return icd9MajMinToCode(newmajor, minor, true); } return icd9MajMinToCode(major, minor, true); }
DataFrameSubsetVisitors::DataFrameSubsetVisitors( const Rcpp::DataFrame& data_, const Rcpp::CharacterVector& names ) : data(data_), visitors(), visitor_names(names), nvisitors(visitor_names.size()) { std::string name ; int n = names.size() ; IntegerVector indices = Language( "match", names, RCPP_GET_NAMES(data) ).fast_eval() ; for( int i=0; i<n; i++){ int pos = indices[i] ; if( pos == NA_INTEGER ){ name = (String)names[i] ; stop( "unknown column '%s' ", name ) ; } visitors.push_back(subset_visitor( data[pos-1] )) ; } }
// [[Rcpp::export]] void write_fasta( Rcpp::CharacterVector seq, std::string seqname, std::string filename, int rowlength=80, int verbose=1) { // rowlength=rowlength-1; FILE * pFile; // pFile=fopen(filename.c_str(),"wt"); pFile=fopen(filename.c_str(),"at"); int i = 0; // unsigned int i = 0; if(verbose == 1){ Rcpp::Rcout << "Processing sample: " << seqname << "\n"; } putc ('>' , pFile); for(i=0; (unsigned)i<seqname.size(); i++){ putc (seqname[i] , pFile); } putc ('\n' , pFile); putc (Rcpp::as< char >(seq[0]) , pFile); for(i=1; i<seq.size(); i++){ Rcpp::checkUserInterrupt(); // putc (seq[i][0] , pFile); if( i % rowlength == 0){ putc('\n', pFile); } putc (Rcpp::as< char >(seq[i]) , pFile); if(i % nreport == 0 && verbose == 1){ Rcpp::Rcout << "\rNucleotide " << i << " processed"; } } putc('\n', pFile); fclose (pFile); if(verbose == 1){ Rcpp::Rcout << "\rNucleotide " << i << " processed\n"; } // return 0; }
DataFrameJoinVisitors::DataFrameJoinVisitors(const Rcpp::DataFrame& left_, const Rcpp::DataFrame& right_, Rcpp::CharacterVector names_left, Rcpp::CharacterVector names_right, bool warn_ ) : left(left_), right(right_), visitor_names_left(names_left), visitor_names_right(names_right), nvisitors(names_left.size()), visitors(nvisitors), warn(warn_) { std::string name_left, name_right ; for( int i=0; i<nvisitors; i++){ name_left = names_left[i] ; name_right = names_right[i] ; try{ visitors[i] = join_visitor( left[name_left], right[name_right], name_left, name_right, warn ) ; } catch( const std::exception& ex ){ stop( "cannot join on columns '%s' x '%s': %s ", name_left, name_right, ex.what() ) ; } catch( ... ){ stop( "cannot join on columns '%s' x '%s'", name_left, name_right ) ; } } }
//[[Rcpp::export]] bool isLabelName(Rcpp::CharacterVector lblToCheck, Rcpp::CharacterVector lbl ) { Rcpp::CharacterVector noLbl = Rcpp::setdiff(lblToCheck, lbl); return noLbl.size() == 0; }
void convertGraphNEL(SEXP graph_sexp, context::inputGraph& graphRef) { Rcpp::S4 graph_s4; try { graph_s4 = Rcpp::as<Rcpp::S4>(graph_sexp); } catch(Rcpp::not_compatible&) { throw std::runtime_error("Input graph must be an S4 object"); } if(Rcpp::as<std::string>(graph_s4.attr("class")) != "graphNEL") { throw std::runtime_error("Input graph must have class graphNEL"); } Rcpp::RObject nodes_obj; try { nodes_obj = Rcpp::as<Rcpp::RObject>(graph_s4.slot("nodes")); } catch(Rcpp::not_compatible&) { throw std::runtime_error("Error extracting slot nodes"); } Rcpp::RObject edges_obj; try { edges_obj = Rcpp::as<Rcpp::RObject>(graph_s4.slot("edgeL")); } catch(Rcpp::not_compatible&) { throw std::runtime_error("Error extracting slot edgeL"); } Rcpp::CharacterVector nodeNames; try { nodeNames = Rcpp::as<Rcpp::CharacterVector>(nodes_obj); } catch(Rcpp::not_compatible&) { throw std::runtime_error("Slot nodes of input graph must be a character vector"); } { std::vector<std::string> uniqueNodeNames = Rcpp::as<std::vector<std::string> >(nodeNames); std::sort(uniqueNodeNames.begin(), uniqueNodeNames.end()); uniqueNodeNames.erase(std::unique(uniqueNodeNames.begin(), uniqueNodeNames.end()), uniqueNodeNames.end()); if((std::size_t)uniqueNodeNames.size() != (std::size_t)nodeNames.size()) { throw std::runtime_error("Node names of input graph were not unique"); } } int nVertices = nodeNames.size(); Rcpp::List edges_list; try { edges_list = Rcpp::as<Rcpp::List>(edges_obj); } catch(Rcpp::not_compatible&) { throw std::runtime_error("Slot edgeL of input graph must be a list"); } Rcpp::CharacterVector edges_list_names = Rcpp::as<Rcpp::CharacterVector>(edges_list.attr("names")); graphRef = context::inputGraph(nVertices); int edgeIndexCounter = 0; for(int i = 0; i < edges_list.size(); i++) { int nodeIndex = std::distance(nodeNames.begin(), std::find(nodeNames.begin(), nodeNames.end(), edges_list_names(i))); Rcpp::List subList; Rcpp::CharacterVector subListNames; try { subList = Rcpp::as<Rcpp::List>(edges_list(i)); subListNames = Rcpp::as<Rcpp::CharacterVector>(subList.attr("names")); } catch(Rcpp::not_compatible&) { throw std::runtime_error("Slot edgeL of input graph had an invalid format"); } if(std::find(subListNames.begin(), subListNames.end(), "edges") == subListNames.end()) { throw std::runtime_error("Slot edgeL of input graph had an invalid format"); } Rcpp::NumericVector targetIndicesThisNode; try { targetIndicesThisNode = Rcpp::as<Rcpp::NumericVector>(subList("edges")); } catch(Rcpp::not_compatible&) { throw std::runtime_error("Slot edgeL of input graph had an invalid format"); } for(int j = 0; j < targetIndicesThisNode.size(); j++) { boost::add_edge((std::size_t)nodeIndex, (std::size_t)((int)targetIndicesThisNode(j)-1), edgeIndexCounter, graphRef); edgeIndexCounter++; } } }
bool isUndirectedGraphNEL(SEXP graph_sexp) { Rcpp::S4 graph_s4; try { graph_s4 = Rcpp::as<Rcpp::S4>(graph_sexp); } catch(Rcpp::not_compatible&) { throw std::runtime_error("Input graph must be an S4 object"); } if(Rcpp::as<std::string>(graph_s4.attr("class")) != "graphNEL") { throw std::runtime_error("Input graph must have class graphNEL"); } Rcpp::RObject nodes_obj; try { nodes_obj = Rcpp::as<Rcpp::RObject>(graph_s4.slot("nodes")); } catch(Rcpp::not_compatible&) { throw std::runtime_error("Error extracting slot nodes"); } Rcpp::RObject edges_obj; try { edges_obj = Rcpp::as<Rcpp::RObject>(graph_s4.slot("edgeL")); } catch(Rcpp::not_compatible&) { throw std::runtime_error("Error extracting slot edgeL"); } Rcpp::CharacterVector nodeNames; try { nodeNames = Rcpp::as<Rcpp::CharacterVector>(nodes_obj); } catch(Rcpp::not_compatible&) { throw std::runtime_error("Slot nodes of input graph must be a character vector"); } { std::vector<std::string> uniqueNodeNames = Rcpp::as<std::vector<std::string> >(nodeNames); std::sort(uniqueNodeNames.begin(), uniqueNodeNames.end()); uniqueNodeNames.erase(std::unique(uniqueNodeNames.begin(), uniqueNodeNames.end()), uniqueNodeNames.end()); if((std::size_t)uniqueNodeNames.size() != (std::size_t)nodeNames.size()) { throw std::runtime_error("Node names of input graph were not unique"); } } int nVertices = nodeNames.size(); Rcpp::List edges_list; try { edges_list = Rcpp::as<Rcpp::List>(edges_obj); } catch(Rcpp::not_compatible&) { throw std::runtime_error("Slot edgeL of input graph must be a list"); } Rcpp::CharacterVector edges_list_names = Rcpp::as<Rcpp::CharacterVector>(edges_list.attr("names")); Context::inputGraph graphRef = Context::inputGraph(nVertices); for(int i = 0; i < edges_list.size(); i++) { int nodeIndex = std::distance(nodeNames.begin(), std::find(nodeNames.begin(), nodeNames.end(), edges_list_names(i))); Rcpp::List subList; Rcpp::CharacterVector subListNames; try { subList = Rcpp::as<Rcpp::List>(edges_list(i)); subListNames = Rcpp::as<Rcpp::CharacterVector>(subList.attr("names")); } catch(Rcpp::not_compatible&) { throw std::runtime_error("Slot edgeL of input graph had an invalid format"); } if(std::find(subListNames.begin(), subListNames.end(), "edges") == subListNames.end()) { throw std::runtime_error("Slot edgeL of input graph had an invalid format"); } Rcpp::NumericVector targetIndicesThisNode; try { targetIndicesThisNode = Rcpp::as<Rcpp::NumericVector>(subList("edges")); } catch(Rcpp::not_compatible&) { throw std::runtime_error("Slot edgeL of input graph had an invalid format"); } for(int j = 0; j < targetIndicesThisNode.size(); j++) { boost::add_edge((std::size_t)nodeIndex, (std::size_t)((int)targetIndicesThisNode(j)-1), graphRef); } } Context::inputGraph::edge_iterator current, end; boost::tie(current, end) = boost::edges(graphRef); for(; current != end; current++) { int source = boost::source(*current, graphRef), target = boost::target(*current, graphRef); if(!boost::edge(target, source, graphRef).second) { return false; } } return true; }
//' rcpp_lines_as_network //' //' Return OSM data in Simple Features format //' //' @param sf_lines An sf collection of LINESTRING objects //' @param pr Rcpp::DataFrame containing the weighting profile //' //' @return Rcpp::List objects of OSM data //' //' @noRd // [[Rcpp::export]] Rcpp::List rcpp_lines_as_network (const Rcpp::List &sf_lines, Rcpp::DataFrame pr) { std::map <std::string, float> profile; Rcpp::StringVector hw = pr [1]; Rcpp::NumericVector val = pr [2]; for (int i = 0; i != hw.size (); i ++) profile.insert (std::make_pair (std::string (hw [i]), val [i])); Rcpp::CharacterVector nms = sf_lines.attr ("names"); if (nms [nms.size () - 1] != "geometry") throw std::runtime_error ("sf_lines have no geometry component"); if (nms [0] != "osm_id") throw std::runtime_error ("sf_lines have no osm_id component"); int one_way_index = -1; int one_way_bicycle_index = -1; int highway_index = -1; for (int i = 0; i < nms.size (); i++) { if (nms [i] == "oneway") one_way_index = i; if (nms [i] == "oneway.bicycle") one_way_bicycle_index = i; if (nms [i] == "highway") highway_index = i; } Rcpp::CharacterVector ow = NULL; Rcpp::CharacterVector owb = NULL; Rcpp::CharacterVector highway = NULL; if (one_way_index >= 0) ow = sf_lines [one_way_index]; if (one_way_bicycle_index >= 0) owb = sf_lines [one_way_bicycle_index]; if (highway_index >= 0) highway = sf_lines [highway_index]; if (ow.size () > 0) { if (ow.size () == owb.size ()) { for (unsigned i = 0; i != ow.size (); ++ i) if (ow [i] == "NA" && owb [i] != "NA") ow [i] = owb [i]; } else if (owb.size () > ow.size ()) ow = owb; } Rcpp::List geoms = sf_lines [nms.size () - 1]; std::vector<bool> isOneWay (geoms.length ()); std::fill (isOneWay.begin (), isOneWay.end (), false); // Get dimension of matrix size_t nrows = 0; int ngeoms = 0; for (auto g = geoms.begin (); g != geoms.end (); ++g) { // Rcpp uses an internal proxy iterator here, NOT a direct copy Rcpp::NumericMatrix gi = (*g); int rows = gi.nrow () - 1; nrows += rows; if (ngeoms < ow.size ()) { if (!(ow [ngeoms] == "yes" || ow [ngeoms] == "-1")) { nrows += rows; isOneWay [ngeoms] = true; } } ngeoms ++; } Rcpp::NumericMatrix nmat = Rcpp::NumericMatrix (Rcpp::Dimension (nrows, 6)); Rcpp::CharacterMatrix idmat = Rcpp::CharacterMatrix (Rcpp::Dimension (nrows, 3)); nrows = 0; ngeoms = 0; int fake_id = 0; for (auto g = geoms.begin (); g != geoms.end (); ++ g) { Rcpp::NumericMatrix gi = (*g); std::string hway = std::string (highway [ngeoms]); float hw_factor = profile [hway]; if (hw_factor == 0.0) hw_factor = 1e-5; hw_factor = 1.0 / hw_factor; Rcpp::List ginames = gi.attr ("dimnames"); Rcpp::CharacterVector rnms; if (ginames.length () > 0) rnms = ginames [0]; else { rnms = Rcpp::CharacterVector (gi.nrow ()); for (int i = 0; i < gi.nrow (); i ++) rnms [i] = fake_id ++; } if (rnms.size () != gi.nrow ()) throw std::runtime_error ("geom size differs from rownames"); for (int i = 1; i < gi.nrow (); i ++) { float d = haversine (gi (i-1, 0), gi (i-1, 1), gi (i, 0), gi (i, 1)); nmat (nrows, 0) = gi (i-1, 0); nmat (nrows, 1) = gi (i-1, 1); nmat (nrows, 2) = gi (i, 0); nmat (nrows, 3) = gi (i, 1); nmat (nrows, 4) = d; nmat (nrows, 5) = d * hw_factor; idmat (nrows, 0) = rnms (i-1); idmat (nrows, 1) = rnms (i); idmat (nrows, 2) = hway; nrows ++; if (isOneWay [ngeoms]) { nmat (nrows, 0) = gi (i, 0); nmat (nrows, 1) = gi (i, 1); nmat (nrows, 2) = gi (i-1, 0); nmat (nrows, 3) = gi (i-1, 1); nmat (nrows, 4) = d; nmat (nrows, 5) = d * hw_factor; idmat (nrows, 0) = rnms (i); idmat (nrows, 1) = rnms (i-1); idmat (nrows, 2) = hway; nrows ++; } } ngeoms ++; } Rcpp::List res (2); res [0] = nmat; res [1] = idmat; return res; }
void handleSchemaError(void* userData, xmlError* error) { Rcpp::CharacterVector * vec = (Rcpp::CharacterVector *) userData; std::string message = std::string(error->message); message.resize(message.size() - 1); vec->push_back(message); }
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 }
// This function constructs the output "clustering" data.frame for the dada(...) function. // This contains core and diagnostic information on each partition (or cluster, or Bi). Rcpp::DataFrame b_make_clustering_df(B *b, Sub **subs, Sub **birth_subs, bool has_quals) { unsigned int i, j, r, s, cind, max_reads; Raw *max_raw; Sub *sub; double q_ave, tot_e; // Create output character-vector of representative sequences for each partition (Bi) Rcpp::CharacterVector Rseqs; char oseq[SEQLEN]; for(i=0;i<b->nclust;i++) { max_reads=0; max_raw = NULL; for(r=0;r<b->bi[i]->nraw;r++) { if(b->bi[i]->raw[r]->reads > max_reads) { max_raw = b->bi[i]->raw[r]; max_reads = max_raw->reads; } } // ntcpy(oseq, b->bi[i]->seq); ntcpy(oseq, max_raw->seq); Rseqs.push_back(std::string(oseq)); } // Create output vectors for other columns of clustering data.frame // Each has one entry for each partition (Bi) Rcpp::IntegerVector Rabunds(b->nclust); // abundances Rcpp::IntegerVector Rzeros(b->nclust); // n0 Rcpp::IntegerVector Rones(b->nclust); // n1 Rcpp::IntegerVector Rraws(b->nclust); // nraw Rcpp::NumericVector Rbirth_pvals(b->nclust); // pvalue at birth Rcpp::NumericVector Rbirth_folds(b->nclust); // fold over-abundance at birth Rcpp::IntegerVector Rbirth_hams(b->nclust); // hamming distance at birth Rcpp::NumericVector Rbirth_es(b->nclust); // expected number at birth Rcpp::CharacterVector Rbirth_types; // DEPRECATED Rcpp::NumericVector Rbirth_qaves(b->nclust); // average quality of substitutions that drove birth Rcpp::NumericVector Rpvals(b->nclust); // post-hoc pvalue // Assign values to the output vectors for(i=0;i<b->nclust;i++) { Rabunds[i] = b->bi[i]->reads; Rraws[i] = b->bi[i]->nraw; // n0 and n1 Rzeros[i] = 0; Rones[i] = 0; for(r=0;r<b->bi[i]->nraw;r++) { sub = subs[b->bi[i]->raw[r]->index]; if(sub) { if(sub->nsubs == 0) { Rzeros[i] += b->bi[i]->raw[r]->reads; } if(sub->nsubs == 1) { Rones[i] += b->bi[i]->raw[r]->reads; } } } // Record information from the cluster's birth Rbirth_types.push_back(std::string(b->bi[i]->birth_type)); if(i==0) { // 0-clust wasn't born normally Rbirth_pvals[i] = Rcpp::NumericVector::get_na(); Rbirth_folds[i] = Rcpp::NumericVector::get_na(); Rbirth_hams[i] = Rcpp::IntegerVector::get_na(); Rbirth_es[i] = Rcpp::NumericVector::get_na(); Rbirth_qaves[i] = Rcpp::NumericVector::get_na(); } else { Rbirth_pvals[i] = b->bi[i]->birth_pval; Rbirth_folds[i] = b->bi[i]->birth_fold; Rbirth_hams[i] = b->bi[i]->birth_comp.hamming; Rbirth_es[i] = b->bi[i]->birth_e; // Calculate average quality of birth substitutions if(has_quals) { q_ave = 0.0; sub = birth_subs[i]; if(sub && sub->q1) { for(s=0;s<sub->nsubs;s++) { q_ave += (sub->q1[s]); } q_ave = q_ave/((double)sub->nsubs); } Rbirth_qaves[i] = q_ave; } else { Rbirth_qaves[i] = Rcpp::NumericVector::get_na(); } } // Calculate post-hoc pval // This is not as exhaustive anymore tot_e = 0.0; for(j=0;j<b->nclust;j++) { if(i != j && b->bi[j]->comp_index.count(b->bi[i]->center->index) > 0) { cind = b->bi[j]->comp_index[b->bi[i]->center->index]; tot_e += b->bi[j]->comp[cind].lambda * b->bi[j]->reads; // b->bi[j]->e[b->bi[i]->center->index]; } } Rpvals[i] = calc_pA(1+b->bi[i]->reads, tot_e); // Add 1 because calc_pA subtracts 1 (conditional p-val) } return(Rcpp::DataFrame::create(_["sequence"] = Rseqs, _["abundance"] = Rabunds, _["n0"] = Rzeros, _["n1"] = Rones, _["nunq"] = Rraws, _["pval"] = Rpvals, _["birth_type"] = Rbirth_types, _["birth_pval"] = Rbirth_pvals, _["birth_fold"] = Rbirth_folds, _["birth_ham"] = Rbirth_hams, _["birth_qave"] = Rbirth_qaves)); }
// [[Rcpp::export]] Rcpp::CharacterVector icd9MajMinToCode(const Rcpp::CharacterVector major, const Rcpp::CharacterVector minor, bool isShort) { #ifdef ICD9_DEBUG_TRACE Rcpp::Rcout << "icd9MajMinToCode: major.size() = " << major.size() << " and minor.size() = " << minor.size() << "\n"; #endif if (major.size() != minor.size()) Rcpp::stop("major and minor lengths differ"); #ifdef ICD9_DEBUG_TRACE Rcpp::Rcout << "major and minor are the same?\n"; #endif Rcpp::CharacterVector out; // wish I could reserve space for this Rcpp::CharacterVector::const_iterator j = major.begin(); Rcpp::CharacterVector::const_iterator n = minor.begin(); for (; j != major.end() && n != minor.end(); ++j, ++n) { Rcpp::String mjrelem = *j; if (mjrelem == NA_STRING) { out.push_back(NA_STRING); continue; } // work around Rcpp bug with push_front: convert to string just for this // TODO: try to do this with C string instead const char* smj_c = mjrelem.get_cstring(); std::string smj = std::string(smj_c); switch (strlen(smj_c)) { case 0: out.push_back(NA_STRING); continue; case 1: if (!icd9IsASingleVE(smj_c)) { smj.insert(0, "00"); } break; case 2: if (!icd9IsASingleVE(smj_c)) { smj.insert(0, "0"); } else { smj.insert(1, "0"); } // default: // major is 3 (or more) chars already } Rcpp::String mnrelem = *n; if (mnrelem == NA_STRING) { //out.push_back(mjrelem); out.push_back(smj); continue; } // this can probably be done more quickly: //std::string smj(mjrelem); if (!isShort && mnrelem != "") { smj.append("."); } smj.append(mnrelem); out.push_back(smj); } // ?slow step somewhere around here, with use of Rcpp::String, maybe in the wrapping? Maybe in the multiple push_back calls //return wrap(out); return out; }