void checkOperandsConformable_full(const VectorBase* vl, const VectorBase* vr)
{
// Temporary kludge:
VectorBase* vlnc = const_cast<VectorBase*>(vl);
VectorBase* vrnc = const_cast<VectorBase*>(vr);
if (Rf_isArray(vlnc) && Rf_isArray(vrnc)
&& !Rf_conformable(vlnc, vrnc))
Rf_error(_("non-conformable arrays"));
if (isTs(vlnc)) {
if (isTs(vrnc) && !Rf_tsConform(vlnc, vrnc))
Rf_error(_("non-conformable time-series"));
if (vr->size() > vl->size())
Rf_error(_("time-series/vector length mismatch"));
} else if (isTs(vrnc) && vl->size() > vr->size())
Rf_error(_("time-series/vector length mismatch"));
}
bool isTv(char ref, char alt) {
if (ref == alt) return false;
if (!isTs(ref, alt)) return true;
return false;
};
int main(int argc, char** argv) {
time_t currentTime = time(0);
fprintf(stderr, "Analysis started at: %s", ctime(¤tTime));
PARSE_PARAMETER(argc, argv);
PARAMETER_STATUS();
if (FLAG_REMAIN_ARG.size() > 0) {
fprintf(stderr, "Unparsed arguments: ");
for (unsigned int i = 0; i < FLAG_REMAIN_ARG.size(); i++) {
fprintf(stderr, " %s", FLAG_REMAIN_ARG[i].c_str());
}
fprintf(stderr, "\n");
abort();
}
REQUIRE_STRING_PARAMETER(FLAG_inVcf,
"Please provide input file using: --inVcf");
const char defaultDbSnp[] =
"/net/fantasia/home/zhanxw/amd/data/umake-resources/dbSNP/"
"dbsnp_129_b37.rod.map";
if (FLAG_snp == "") {
FLAG_snp = defaultDbSnp;
fprintf(stderr, "Use default dbsnp: [ %s ]\n", defaultDbSnp);
}
SiteSet snpSet;
snpSet.loadRodFile(FLAG_snp);
fprintf(stderr, "%zu dbSNP sites loaded.\n", snpSet.getTotalSite());
const char defaultHM3[] =
"/net/fantasia/home/zhanxw/amd/data/umake-resources/HapMap3/"
"hapmap3_r3_b37_fwd.consensus.qc.poly.bim";
if (FLAG_hapmap == "") {
FLAG_hapmap = defaultHM3;
fprintf(stderr, "Use default HapMap: [ %s ]\n", defaultHM3);
}
SiteSet hmSet;
hmSet.loadBimFile(FLAG_hapmap);
fprintf(stderr, "%zu Hapmap sites loaded.\n", hmSet.getTotalSite());
const char* fn = FLAG_inVcf.c_str();
LineReader lr(fn);
// // set range filters here
// // e.g.
// // vin.setRangeList("1:69500-69600");
// vin.setRangeList(FLAG_rangeList.c_str());
// vin.setRangeFile(FLAG_rangeFile.c_str());
std::map<std::string, Variant> freq;
std::string chrom;
int pos;
std::string filt;
char ref, alt;
bool inDbSnp;
bool inHapmap;
int lineNo = 0;
std::vector<std::string> fd;
while (lr.readLineBySep(&fd, " \t")) {
lineNo++;
if (fd[0][0] == '#') continue; // skip header
chrom = fd[0]; // ref is on column 0 (0-based)
pos = atoi(fd[1]); // ref is on column 1 (0-based)
ref = fd[3][0]; // ref is on column 3 (0-based)
alt = fd[4][0]; // ref is on column 4 (0-based)
filt = fd[6]; // filt is on column 6 (0-based)
inDbSnp = snpSet.isIncluded(chrom.c_str(), pos);
inHapmap = hmSet.isIncluded(chrom.c_str(), pos);
Variant& v = freq[filt];
v.total++;
if (isTs(ref, alt)) {
v.ts++;
if (inDbSnp) {
v.tsInDbSnp++;
v.dbSnp++;
}
} else if (isTv(ref, alt)) {
v.tv++;
if (inDbSnp) {
v.tvInDbSnp++;
v.dbSnp++;
}
};
if (inHapmap) v.hapmap++;
};
fprintf(stdout, "Total %d VCF records have converted successfully\n", lineNo);
//////////////////////////////////////////////////////////////////////
std::string title = "Summarize per combined filter";
int pad = (170 - title.size()) / 2;
std::string outTitle = std::string(pad, '-') + title + std::string(pad, '-');
puts(outTitle.c_str());
printf("%40s\t%10s\t%10s\t%10s\t%10s\t%10s\t%10s\t%10s\t%10s\n", "Filter",
"#SNPs", "#dbSNP", "%dbSNP", "Known Ts/Tv", "Novel Ts/Tv", "Overall",
"%TotalHM3", "%HMCalled");
std::map<std::string, Variant> indvFreq;
Variant pass;
Variant fail;
Variant total;
std::vector<std::string> filters; // individual filter
for (std::map<std::string, Variant>::iterator i = freq.begin();
i != freq.end(); ++i) {
const std::string& filt = i->first;
const Variant& v = i->second;
v.print(filt, hmSet);
// calculate indvFreq, pass, fail and total
stringTokenize(filt, ';', &filters);
for (unsigned int j = 0; j < filters.size(); j++) {
const std::string& filt = filters[j];
indvFreq[filt] += v;
}
if (filt == "PASS")
pass += v;
else
fail += v;
total += v;
};
//////////////////////////////////////////////////////////////////////
title = "Summarize per individual filter";
pad = (170 - title.size()) / 2;
outTitle = std::string(pad, '-') + title + std::string(pad, '-');
puts(outTitle.c_str());
printf("%40s\t%10s\t%10s\t%10s\t%10s\t%10s\t%10s\t%10s\t%10s\n", "Filter",
"#SNPs", "#dbSNP", "%dbSNP", "Known Ts/Tv", "Novel Ts/Tv", "Overall",
"%TotalHM3", "%HMCalled");
for (std::map<std::string, Variant>::iterator i = indvFreq.begin();
i != indvFreq.end(); ++i) {
const std::string& filt = i->first;
const Variant& v = i->second;
v.print(filt, hmSet);
}
//////////////////////////////////////////////////////////////////////
title = "Summarize per pass/fail filter";
pad = (170 - title.size()) / 2;
outTitle = std::string(pad, '-') + title + std::string(pad, '-');
puts(outTitle.c_str());
printf("%40s\t%10s\t%10s\t%10s\t%10s\t%10s\t%10s\t%10s\t%10s\n", "Filter",
"#SNPs", "#dbSNP", "%dbSNP", "Known Ts/Tv", "Novel Ts/Tv", "Overall",
"%TotalHM3", "%HMCalled");
pass.print("PASS", hmSet);
fail.print("FAIL", hmSet);
total.print("TOTAL", hmSet);
currentTime = time(0);
fprintf(stderr, "Analysis end at: %s", ctime(¤tTime));
return 0;
};
static SEXP lbinary(SEXP call, SEXP op, SEXP args)
{
/* logical binary : "&" or "|" */
SEXP x, y, dims, tsp, klass, xnames, ynames;
R_xlen_t mismatch, nx, ny;
int xarray, yarray, xts, yts;
mismatch = 0;
x = CAR(args);
y = CADR(args);
if (isRaw(x) && isRaw(y)) {
}
else if (!isNumber(x) || !isNumber(y))
errorcall(call,
_("operations are possible only for numeric, logical or complex types"));
tsp = R_NilValue; /* -Wall */
klass = R_NilValue; /* -Wall */
xarray = isArray(x);
yarray = isArray(y);
xts = isTs(x);
yts = isTs(y);
if (xarray || yarray) {
if (xarray && yarray) {
if (!conformable(x, y))
error(_("binary operation on non-conformable arrays"));
PROTECT(dims = getAttrib(x, R_DimSymbol));
}
else if (xarray) {
PROTECT(dims = getAttrib(x, R_DimSymbol));
}
else /*(yarray)*/ {
PROTECT(dims = getAttrib(y, R_DimSymbol));
}
PROTECT(xnames = getAttrib(x, R_DimNamesSymbol));
PROTECT(ynames = getAttrib(y, R_DimNamesSymbol));
}
else {
PROTECT(dims = R_NilValue);
PROTECT(xnames = getAttrib(x, R_NamesSymbol));
PROTECT(ynames = getAttrib(y, R_NamesSymbol));
}
nx = XLENGTH(x);
ny = XLENGTH(y);
if(nx > 0 && ny > 0) {
if(nx > ny) mismatch = nx % ny;
else mismatch = ny % nx;
}
if (xts || yts) {
if (xts && yts) {
if (!tsConform(x, y))
errorcall(call, _("non-conformable time series"));
PROTECT(tsp = getAttrib(x, R_TspSymbol));
PROTECT(klass = getAttrib(x, R_ClassSymbol));
}
else if (xts) {
if (XLENGTH(x) < XLENGTH(y))
ErrorMessage(call, ERROR_TSVEC_MISMATCH);
PROTECT(tsp = getAttrib(x, R_TspSymbol));
PROTECT(klass = getAttrib(x, R_ClassSymbol));
}
else /*(yts)*/ {
if (XLENGTH(y) < XLENGTH(x))
ErrorMessage(call, ERROR_TSVEC_MISMATCH);
PROTECT(tsp = getAttrib(y, R_TspSymbol));
PROTECT(klass = getAttrib(y, R_ClassSymbol));
}
}
if(mismatch)
warningcall(call,
_("longer object length is not a multiple of shorter object length"));
if (isRaw(x) && isRaw(y)) {
PROTECT(x = binaryLogic2(PRIMVAL(op), x, y));
} else {
if (!isNumber(x) || !isNumber(y))
errorcall(call,
_("operations are possible only for numeric, logical or complex types"));
x = SETCAR(args, coerceVector(x, LGLSXP));
y = SETCADR(args, coerceVector(y, LGLSXP));
PROTECT(x = binaryLogic(PRIMVAL(op), x, y));
}
if (dims != R_NilValue) {
setAttrib(x, R_DimSymbol, dims);
if(xnames != R_NilValue)
setAttrib(x, R_DimNamesSymbol, xnames);
else if(ynames != R_NilValue)
setAttrib(x, R_DimNamesSymbol, ynames);
}
else {
if(XLENGTH(x) == XLENGTH(xnames))
setAttrib(x, R_NamesSymbol, xnames);
else if(XLENGTH(x) == XLENGTH(ynames))
setAttrib(x, R_NamesSymbol, ynames);
}
if (xts || yts) {
setAttrib(x, R_TspSymbol, tsp);
setAttrib(x, R_ClassSymbol, klass);
UNPROTECT(2);
}
UNPROTECT(4);
return x;
}
int main(int argc, char** argv){
time_t currentTime = time(0);
fprintf(stderr, "Analysis started at: %s", ctime(¤tTime));
////////////////////////////////////////////////
BEGIN_PARAMETER_LIST(pl)
ADD_PARAMETER_GROUP(pl, "Input/Output")
ADD_STRING_PARAMETER(pl, inVcf, "--inVcf", "input VCF File")
ADD_STRING_PARAMETER(pl, snp, "--snp", "input dbSNP File (.rod)")
ADD_STRING_PARAMETER(pl, hapmap, "--hapmap", "input HapMap File (.bim)")
ADD_PARAMETER_GROUP(pl, "Site Filter")
ADD_STRING_PARAMETER(pl, rangeList, "--rangeList", "Specify some ranges to use, please use chr:begin-end format.")
ADD_STRING_PARAMETER(pl, rangeFile, "--rangeFile", "Specify the file containing ranges, please use chr:begin-end format.")
END_PARAMETER_LIST(pl)
;
pl.Read(argc, argv);
pl.Status();
if (FLAG_REMAIN_ARG.size() > 0){
fprintf(stderr, "Unparsed arguments: ");
for (unsigned int i = 0; i < FLAG_REMAIN_ARG.size(); i++){
fprintf(stderr, " %s", FLAG_REMAIN_ARG[i].c_str());
}
fprintf(stderr, "\n");
abort();
}
REQUIRE_STRING_PARAMETER(FLAG_inVcf, "Please provide input file using: --inVcf");
const char defaultDbSnp[] = "/net/fantasia/home/zhanxw/amd/data/umake-resources/dbSNP/dbsnp_129_b37.rod.map";
if (FLAG_snp == "") {
FLAG_snp = defaultDbSnp;
fprintf(stderr, "Use default dbsnp: [ %s ]\n", defaultDbSnp);
}
SiteSet snpSet;
snpSet.loadRodFile(FLAG_snp);
fprintf(stderr, "%zu dbSNP sites loaded.\n", snpSet.getTotalSite());
const char defaultHM3[] = "/net/fantasia/home/zhanxw/amd/data/umake-resources/HapMap3/hapmap3_r3_b37_fwd.consensus.qc.poly.bim";
if (FLAG_hapmap == "") {
FLAG_hapmap = defaultHM3;
fprintf(stderr, "Use default HapMap: [ %s ]\n", defaultHM3);
}
SiteSet hmSet;
hmSet.loadBimFile(FLAG_hapmap);
fprintf(stderr, "%zu Hapmap sites loaded.\n", hmSet.getTotalSite());
const char* fn = FLAG_inVcf.c_str();
LineReader lr(fn);
// // set range filters here
// // e.g.
// // vin.setRangeList("1:69500-69600");
// vin.setRangeList(FLAG_rangeList.c_str());
// vin.setRangeFile(FLAG_rangeFile.c_str());
std::map<std::string, Variant> freq;
std::string chrom;
int pos;
// std::string filt;
std::string anno;
char ref, alt;
bool inDbSnp;
bool inHapmap;
int lineNo = 0;
std::vector<std::string> fd;
while(lr.readLineBySep(&fd, " \t")){
lineNo ++;
if (fd[0][0] == '#') continue; // skip header
chrom = fd[0]; // ref is on column 0 (0-based)
pos = atoi(fd[1]); // ref is on column 1 (0-based)
ref = fd[3][0]; // ref is on column 3 (0-based)
alt = fd[4][0]; // ref is on column 4 (0-based)
// filt = fd[6]; // filt is on column 6 (0-based)
anno = extractAnno(fd[7]); // info is on column 7 (0-based), we will extract ANNO=
inDbSnp = snpSet.isIncluded(chrom.c_str(), pos);
inHapmap = hmSet.isIncluded(chrom.c_str(), pos);
Variant& v = freq[anno];
v.total++;
if ( isTs(ref, alt) ) {
v.ts ++;
if (inDbSnp) {
v.tsInDbSnp ++;
v.dbSnp ++;
}
} else if (isTv(ref, alt)) {
v.tv ++;
if (inDbSnp) {
v.tvInDbSnp ++;
v.dbSnp ++;
}
};
if (inHapmap)
v.hapmap ++;
if (lineNo % 10000 == 0) {
fprintf(stderr, "\rProcessed %d lines...\r", lineNo);
}
};
fprintf(stdout, "Total %d VCF records have been read successfully\n", lineNo);
//////////////////////////////////////////////////////////////////////
std::string title = "Summarize per annotation type";
int pad = (170 - title.size() ) /2 ;
std::string outTitle = std::string(pad, '-') + title + std::string(pad, '-');
puts(outTitle.c_str());
printf("%40s\t%10s\t%10s\t%10s\t%10s\t%10s\t%10s\t%10s\t%10s\n",
"Filter", "#SNPs", "#dbSNP", "%dbSNP", "Known Ts/Tv", "Novel Ts/Tv", "Overall", "%TotalHM3", "%HMCalled");
std::map<std::string, Variant> indvFreq;
Variant total;
for (std::map<std::string, Variant>::iterator i = freq.begin() ; i != freq.end(); ++i ){
i->second.print(i->first, hmSet);
total += i->second;
};
total.print("TOTAL", hmSet);
currentTime = time(0);
fprintf(stderr, "Analysis end at: %s", ctime(¤tTime));
return 0;
};
int main(int argc, char** argv) {
time_t currentTime = time(0);
fprintf(stderr, "Analysis started at: %s", ctime(¤tTime));
PARSE_PARAMETER(argc, argv);
PARAMETER_STATUS();
if (FLAG_REMAIN_ARG.size() > 0) {
fprintf(stderr, "Unparsed arguments: ");
for (unsigned int i = 0; i < FLAG_REMAIN_ARG.size(); i++) {
fprintf(stderr, " %s", FLAG_REMAIN_ARG[i].c_str());
}
fprintf(stderr, "\n");
abort();
}
REQUIRE_STRING_PARAMETER(FLAG_inVcf,
"Please provide input file using: --inVcf");
const char defaultDbSnp[] =
"/net/fantasia/home/zhanxw/amd/data/umake-resources/dbSNP/"
"dbsnp_129_b37.rod.map";
if (FLAG_snp == "") {
FLAG_snp = defaultDbSnp;
fprintf(stderr, "Use default dbsnp: [ %s ]\n", defaultDbSnp);
}
SiteSet snpSet;
snpSet.loadRodFile(FLAG_snp);
fprintf(stderr, "%zu dbSNP sites loaded.\n", snpSet.getTotalSite());
const char defaultHM3[] =
"/net/fantasia/home/zhanxw/amd/data/umake-resources/HapMap3/"
"hapmap3_r3_b37_fwd.consensus.qc.poly.bim";
if (FLAG_hapmap == "") {
FLAG_hapmap = defaultHM3;
fprintf(stderr, "Use default HapMap: [ %s ]\n", defaultHM3);
}
SiteSet hmSet;
hmSet.loadBimFile(FLAG_hapmap);
fprintf(stderr, "%zu Hapmap sites loaded.\n", hmSet.getTotalSite());
const char* fn = FLAG_inVcf.c_str();
LineReader lr(fn);
// // set range filters here
// // e.g.
// // vin.setRangeList("1:69500-69600");
// vin.setRangeList(FLAG_rangeList.c_str());
// vin.setRangeFile(FLAG_rangeFile.c_str());
std::map<std::string, Variant> freq;
std::string chrom;
int pos;
// std::string filt;
// std::string anno;
std::string numVariant;
char ref, alt;
bool inDbSnp;
bool inHapmap;
int lineNo = 0;
std::vector<std::string> fd;
while (lr.readLineBySep(&fd, " \t")) {
lineNo++;
if (fd[0][0] == '#') continue; // skip header
chrom = fd[0]; // ref is on column 0 (0-based)
pos = atoi(fd[1]); // ref is on column 1 (0-based)
ref = fd[3][0]; // ref is on column 3 (0-based)
alt = fd[4][0]; // ref is on column 4 (0-based)
// filt = fd[6]; // filt is on column 6 (0-based)
// anno = extractAnno(fd[7]); // info is on column 7 (0-based), we will
// extract ANNO=
// obtain number of variants
if (fd.size() <= 9) { // first 9 columns are not individuals
numVariant = toString(0);
} else {
int numVar = 0;
for (size_t i = 9; i < fd.size(); ++i) {
int varCount = countVariant(fd[i]);
if (varCount > 0) numVar += varCount;
}
numVariant = toString(numVar);
}
inDbSnp = snpSet.isIncluded(chrom.c_str(), pos);
inHapmap = hmSet.isIncluded(chrom.c_str(), pos);
Variant& v = freq[numVariant];
v.total++;
if (isTs(ref, alt)) {
v.ts++;
if (inDbSnp) {
v.tsInDbSnp++;
v.dbSnp++;
}
} else if (isTv(ref, alt)) {
v.tv++;
if (inDbSnp) {
v.tvInDbSnp++;
v.dbSnp++;
}
};
if (inHapmap) v.hapmap++;
if (lineNo % 10000 == 0) {
fprintf(stderr, "\rProcessed %d lines...\r", lineNo);
}
};
fprintf(stdout, "Total %d VCF records have been read successfully\n", lineNo);
//////////////////////////////////////////////////////////////////////
std::string title = "Summarize per annotation type";
int pad = (170 - title.size()) / 2;
std::string outTitle = std::string(pad, '-') + title + std::string(pad, '-');
puts(outTitle.c_str());
printf("%40s\t%10s\t%10s\t%10s\t%10s\t%10s\t%10s\t%10s\t%10s\n", "Filter",
"#SNPs", "#dbSNP", "%dbSNP", "Known Ts/Tv", "Novel Ts/Tv", "Overall",
"%TotalHM3", "%HMCalled");
std::map<std::string, Variant> indvFreq;
Variant total;
// to sort variants by its integer order, we use a temporary map
std::map<int, Variant> tmp;
for (std::map<std::string, Variant>::iterator i = freq.begin();
i != freq.end(); ++i) {
tmp[atoi(i->first)] = i->second;
};
for (std::map<int, Variant>::iterator i = tmp.begin(); i != tmp.end(); ++i) {
i->second.print(toString(i->first), hmSet);
total += i->second;
};
total.print("TOTAL", hmSet);
currentTime = time(0);
fprintf(stderr, "Analysis end at: %s", ctime(¤tTime));
return 0;
};
static SEXP lbinary(SEXP call, SEXP op, SEXP args)
{
/* logical binary : "&" or "|" */
SEXP
x = CAR(args),
y = CADR(args);
if (isRaw(x) && isRaw(y)) {
}
else if ( !(isNull(x) || isNumber(x)) ||
!(isNull(y) || isNumber(y)) )
errorcall(call,
_("operations are possible only for numeric, logical or complex types"));
R_xlen_t
nx = xlength(x),
ny = xlength(y);
Rboolean
xarray = isArray(x),
yarray = isArray(y),
xts = isTs(x),
yts = isTs(y);
SEXP dims, xnames, ynames;
if (xarray || yarray) {
if (xarray && yarray) {
if (!conformable(x, y))
errorcall(call, _("non-conformable arrays"));
PROTECT(dims = getAttrib(x, R_DimSymbol));
}
else if (xarray && (ny != 0 || nx == 0)) {
PROTECT(dims = getAttrib(x, R_DimSymbol));
}
else if (yarray && (nx != 0 || ny == 0)) {
PROTECT(dims = getAttrib(y, R_DimSymbol));
} else
PROTECT(dims = R_NilValue);
PROTECT(xnames = getAttrib(x, R_DimNamesSymbol));
PROTECT(ynames = getAttrib(y, R_DimNamesSymbol));
}
else {
PROTECT(dims = R_NilValue);
PROTECT(xnames = getAttrib(x, R_NamesSymbol));
PROTECT(ynames = getAttrib(y, R_NamesSymbol));
}
SEXP klass = NULL, tsp = NULL; // -Wall
if (xts || yts) {
if (xts && yts) {
if (!tsConform(x, y))
errorcall(call, _("non-conformable time series"));
PROTECT(tsp = getAttrib(x, R_TspSymbol));
PROTECT(klass = getAttrib(x, R_ClassSymbol));
}
else if (xts) {
if (nx < ny)
ErrorMessage(call, ERROR_TSVEC_MISMATCH);
PROTECT(tsp = getAttrib(x, R_TspSymbol));
PROTECT(klass = getAttrib(x, R_ClassSymbol));
}
else /*(yts)*/ {
if (ny < nx)
ErrorMessage(call, ERROR_TSVEC_MISMATCH);
PROTECT(tsp = getAttrib(y, R_TspSymbol));
PROTECT(klass = getAttrib(y, R_ClassSymbol));
}
}
if (nx > 0 && ny > 0) {
if(((nx > ny) ? nx % ny : ny % nx) != 0) // mismatch
warningcall(call,
_("longer object length is not a multiple of shorter object length"));
if (isRaw(x) && isRaw(y)) {
x = binaryLogic2(PRIMVAL(op), x, y);
}
else {
if(isNull(x))
x = SETCAR(args, allocVector(LGLSXP, 0));
else // isNumeric(x)
x = SETCAR(args, coerceVector(x, LGLSXP));
if(isNull(y))
y = SETCAR(args, allocVector(LGLSXP, 0));
else // isNumeric(y)
y = SETCADR(args, coerceVector(y, LGLSXP));
x = binaryLogic(PRIMVAL(op), x, y);
}
} else { // nx == 0 || ny == 0
x = allocVector(LGLSXP, 0);
}
PROTECT(x);
if (dims != R_NilValue) {
setAttrib(x, R_DimSymbol, dims);
if(xnames != R_NilValue)
setAttrib(x, R_DimNamesSymbol, xnames);
else if(ynames != R_NilValue)
setAttrib(x, R_DimNamesSymbol, ynames);
}
else {
if(xnames != R_NilValue && XLENGTH(x) == XLENGTH(xnames))
setAttrib(x, R_NamesSymbol, xnames);
else if(ynames != R_NilValue && XLENGTH(x) == XLENGTH(ynames))
setAttrib(x, R_NamesSymbol, ynames);
}
if (xts || yts) {
setAttrib(x, R_TspSymbol, tsp);
setAttrib(x, R_ClassSymbol, klass);
UNPROTECT(2);
}
UNPROTECT(4);
return x;
}
SEXP attribute_hidden do_relop_dflt(SEXP call, SEXP op, SEXP x, SEXP y)
{
SEXP klass = R_NilValue, dims, tsp=R_NilValue, xnames, ynames;
int nx, ny, xarray, yarray, xts, yts;
Rboolean mismatch = FALSE, iS;
PROTECT_INDEX xpi, ypi;
PROTECT_WITH_INDEX(x, &xpi);
PROTECT_WITH_INDEX(y, &ypi);
nx = length(x);
ny = length(y);
/* pre-test to handle the most common case quickly.
Used to skip warning too ....
*/
if (ATTRIB(x) == R_NilValue && ATTRIB(y) == R_NilValue &&
TYPEOF(x) == REALSXP && TYPEOF(y) == REALSXP &&
LENGTH(x) > 0 && LENGTH(y) > 0) {
SEXP ans = real_relop((RELOP_TYPE) PRIMVAL(op), x, y);
if (nx > 0 && ny > 0)
mismatch = ((nx > ny) ? nx % ny : ny % nx) != 0;
if (mismatch) {
PROTECT(ans);
warningcall(call, _("longer object length is not a multiple of shorter object length"));
UNPROTECT(1);
}
UNPROTECT(2);
return ans;
}
/* That symbols and calls were allowed was undocumented prior to
R 2.5.0. We deparse them as deparse() would, minus attributes */
if ((iS = isSymbol(x)) || TYPEOF(x) == LANGSXP) {
SEXP tmp = allocVector(STRSXP, 1);
PROTECT(tmp);
SET_STRING_ELT(tmp, 0, (iS) ? PRINTNAME(x) :
STRING_ELT(deparse1(x, 0, DEFAULTDEPARSE), 0));
REPROTECT(x = tmp, xpi);
UNPROTECT(1);
}
if ((iS = isSymbol(y)) || TYPEOF(y) == LANGSXP) {
SEXP tmp = allocVector(STRSXP, 1);
PROTECT(tmp);
SET_STRING_ELT(tmp, 0, (iS) ? PRINTNAME(y) :
STRING_ELT(deparse1(y, 0, DEFAULTDEPARSE), 0));
REPROTECT(y = tmp, ypi);
UNPROTECT(1);
}
if (!isVector(x) || !isVector(y)) {
if (isNull(x) || isNull(y)) {
UNPROTECT(2);
return allocVector(LGLSXP,0);
}
errorcall(call,
_("comparison (%d) is possible only for atomic and list types"),
PRIMVAL(op));
}
if (TYPEOF(x) == EXPRSXP || TYPEOF(y) == EXPRSXP)
errorcall(call, _("comparison is not allowed for expressions"));
/* ELSE : x and y are both atomic or list */
if (LENGTH(x) <= 0 || LENGTH(y) <= 0) {
UNPROTECT(2);
return allocVector(LGLSXP,0);
}
mismatch = FALSE;
xarray = isArray(x);
yarray = isArray(y);
xts = isTs(x);
yts = isTs(y);
if (nx > 0 && ny > 0)
mismatch = ((nx > ny) ? nx % ny : ny % nx) != 0;
if (xarray || yarray) {
if (xarray && yarray) {
if (!conformable(x, y))
errorcall(call, _("non-conformable arrays"));
PROTECT(dims = getAttrib(x, R_DimSymbol));
}
else if (xarray) {
PROTECT(dims = getAttrib(x, R_DimSymbol));
}
else /*(yarray)*/ {
PROTECT(dims = getAttrib(y, R_DimSymbol));
}
PROTECT(xnames = getAttrib(x, R_DimNamesSymbol));
PROTECT(ynames = getAttrib(y, R_DimNamesSymbol));
}
else {
PROTECT(dims = R_NilValue);
PROTECT(xnames = getAttrib(x, R_NamesSymbol));
PROTECT(ynames = getAttrib(y, R_NamesSymbol));
}
if (xts || yts) {
if (xts && yts) {
if (!tsConform(x, y))
errorcall(call, _("non-conformable time series"));
PROTECT(tsp = getAttrib(x, R_TspSymbol));
PROTECT(klass = getAttrib(x, R_ClassSymbol));
}
else if (xts) {
if (length(x) < length(y))
ErrorMessage(call, ERROR_TSVEC_MISMATCH);
PROTECT(tsp = getAttrib(x, R_TspSymbol));
PROTECT(klass = getAttrib(x, R_ClassSymbol));
}
else /*(yts)*/ {
if (length(y) < length(x))
ErrorMessage(call, ERROR_TSVEC_MISMATCH);
PROTECT(tsp = getAttrib(y, R_TspSymbol));
PROTECT(klass = getAttrib(y, R_ClassSymbol));
}
}
if (mismatch)
warningcall(call, _("longer object length is not a multiple of shorter object length"));
if (isString(x) || isString(y)) {
REPROTECT(x = coerceVector(x, STRSXP), xpi);
REPROTECT(y = coerceVector(y, STRSXP), ypi);
x = string_relop((RELOP_TYPE) PRIMVAL(op), x, y);
}
else if (isComplex(x) || isComplex(y)) {
REPROTECT(x = coerceVector(x, CPLXSXP), xpi);
REPROTECT(y = coerceVector(y, CPLXSXP), ypi);
x = complex_relop((RELOP_TYPE) PRIMVAL(op), x, y, call);
}
else if (isReal(x) || isReal(y)) {
REPROTECT(x = coerceVector(x, REALSXP), xpi);
REPROTECT(y = coerceVector(y, REALSXP), ypi);
x = real_relop((RELOP_TYPE) PRIMVAL(op), x, y);
}
else if (isInteger(x) || isInteger(y)) {
REPROTECT(x = coerceVector(x, INTSXP), xpi);
REPROTECT(y = coerceVector(y, INTSXP), ypi);
x = integer_relop((RELOP_TYPE) PRIMVAL(op), x, y);
}
else if (isLogical(x) || isLogical(y)) {
REPROTECT(x = coerceVector(x, LGLSXP), xpi);
REPROTECT(y = coerceVector(y, LGLSXP), ypi);
x = integer_relop((RELOP_TYPE) PRIMVAL(op), x, y);
}
else if (TYPEOF(x) == RAWSXP || TYPEOF(y) == RAWSXP) {
REPROTECT(x = coerceVector(x, RAWSXP), xpi);
REPROTECT(y = coerceVector(y, RAWSXP), ypi);
x = raw_relop((RELOP_TYPE) PRIMVAL(op), x, y);
} else errorcall(call, _("comparison of these types is not implemented"));
PROTECT(x);
if (dims != R_NilValue) {
setAttrib(x, R_DimSymbol, dims);
if (xnames != R_NilValue)
setAttrib(x, R_DimNamesSymbol, xnames);
else if (ynames != R_NilValue)
setAttrib(x, R_DimNamesSymbol, ynames);
}
else {
if (length(x) == length(xnames))
setAttrib(x, R_NamesSymbol, xnames);
else if (length(x) == length(ynames))
setAttrib(x, R_NamesSymbol, ynames);
}
if (xts || yts) {
setAttrib(x, R_TspSymbol, tsp);
setAttrib(x, R_ClassSymbol, klass);
UNPROTECT(2);
}
UNPROTECT(6);
return x;
}