// [[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;
}
