SEXP cqlsVectorList_to_R_as_dataframe(CQLS_VECTOR_LIST self) {
PT_LIST pt;
int k,i,j,ii,cpt;
SEXP resR,*tmpR,tmpR2,rownameR;
CQLS_VECTOR vector;
DOUBLE *res;
vector=self->vector;
cpt=eblist_length(self->list);
PROTECT(resR=allocVector(VECSXP,vector->nbVector));//resR<-list()
tmpR=(SEXP*)Calloc(vector->nbVector,SEXP);
PROTECT(rownameR = allocVector(INTSXP, cpt));
for(i=0;i<vector->nbVector;i++) PROTECT(tmpR[i]=allocVector(REALSXP,cpt));
for(pt=self->list,k=0;pt!=NULL;pt=pt->pt_next,k++) {
res=(DOUBLE*)pt->pt_cur;
//Rprintf("k=%d,%LF\n",k,res[0]);
for(i=0;i<vector->nbVector;i++) REAL(tmpR[i])[k] = res[i];
INTEGER(rownameR)[k] = k+1;
}
for(i=0;i<vector->nbVector;i++) SET_VECTOR_ELT(resR,i,tmpR[i]);
setAttrib(resR, R_NamesSymbol,cqlsVector_Rnames(vector));
PROTECT(tmpR2 = allocVector(STRSXP, 1));
SET_STRING_ELT(tmpR2, 0, mkChar("data.frame"));
classgets(resR, tmpR2);
setAttrib(resR, R_RowNamesSymbol, rownameR);
UNPROTECT(1);
UNPROTECT(2 + vector->nbVector);
Free(tmpR);
return resR;
}
SEXP cqlsVector_vector_array_to_R_as_dataframe(CQLS_VECTOR vector,DOUBLE** vectorAry,int arySize,int* weight) {
int k,i;
SEXP resR,*tmpR,tmpR2,rownameR;
//Rprintf("cqlsVector_vector_array_to_R_as_dataframe\n");
PROTECT(resR=allocVector(VECSXP,vector->nbVector));//resR<-list()
tmpR=(SEXP*)Calloc(vector->nbVector,SEXP);
PROTECT(rownameR = allocVector(INTSXP, arySize));
for(i=0;i<vector->nbVector;i++) PROTECT(tmpR[i]=allocVector(REALSXP,arySize));
for(k=0;k<arySize;k++) {
//Rprintf("k=%d,%LF\n",k,vectorAry[k][0]);
for(i=0;i<vector->nbVector;i++) REAL(tmpR[i])[k] = vectorAry[k][i];
INTEGER(rownameR)[k] = k+1;
}
for(i=0;i<vector->nbVector;i++) SET_VECTOR_ELT(resR,i,tmpR[i]);
setAttrib(resR, R_NamesSymbol,cqlsVector_Rnames(vector));
PROTECT(tmpR2 = allocVector(STRSXP, 1));
SET_STRING_ELT(tmpR2, 0, mkChar("data.frame"));
classgets(resR, tmpR2);
setAttrib(resR, R_RowNamesSymbol, rownameR);
UNPROTECT(1);
UNPROTECT(2 + vector->nbVector);
Free(tmpR);
return resR;
}
inline SEXP KMedoidBaseWorker(KMedoidBase *ds) {
SEXP SDO, classname;
PROTECT(classname = allocVector(STRSXP, 1));
SET_STRING_ELT(classname, 0, mkChar("KMedoidBase"));
SDO = R_MakeExternalPtr(ds, R_NilValue, R_NilValue);
R_RegisterCFinalizerEx(SDO, (R_CFinalizer_t) finalizeKMedoidBase, TRUE);
classgets(SDO, classname);
UNPROTECT(1);
return SDO;
}
SEXP mmongo_create() {
SEXP ret, ptr, cls;
PROTECT(ret = allocVector(INTSXP, 1));
INTEGER(ret)[0] = 0;
mongo* conn = Calloc(1, mongo);
ptr = R_MakeExternalPtr(conn, sym_mongo, R_NilValue);
PROTECT(ptr);
R_RegisterCFinalizerEx(ptr, mongoFinalizer, TRUE);
setAttrib(ret, sym_mongo, ptr);
PROTECT(cls = allocVector(STRSXP, 1));
SET_STRING_ELT(cls, 0, mkChar("mongo"));
classgets(ret, cls);
UNPROTECT(3);
return ret;
}
SEXP _mongo_gridfile_create(SEXP gfs, gridfile* gfile) {
SEXP ret, ptr, cls;
PROTECT(ret = allocVector(INTSXP, 1));
INTEGER(ret)[0] = 0;
/* prevent GC on gridfs object while gridfile alive */
setAttrib(ret, sym_mongo_gridfs, gfs);
ptr = R_MakeExternalPtr(gfile, sym_mongo_gridfile, R_NilValue);
PROTECT(ptr);
R_RegisterCFinalizerEx(ptr, mongoGridfileFinalizer, TRUE);
setAttrib(ret, sym_mongo_gridfile, ptr);
PROTECT(cls = allocVector(STRSXP, 1));
SET_STRING_ELT(cls, 0, mkChar("mongo.gridfile"));
classgets(ret, cls);
UNPROTECT(3);
return ret;
}
SEXP mongo_gridfile_writer_create(SEXP gfs, SEXP remotename, SEXP contenttype) {
gridfs* _gfs = _checkGridfs(gfs);
const char* _remotename = CHAR(STRING_ELT(remotename, 0));
const char* _contenttype = CHAR(STRING_ELT(contenttype, 0));
gridfile* gfile = Calloc(1, gridfile);
SEXP ret, ptr, cls;
PROTECT(ret = allocVector(INTSXP, 1));
INTEGER(ret)[0] = 0;
/* prevent GC on gridfs object while gridfile alive */
setAttrib(ret, sym_mongo_gridfs, gfs);
ptr = R_MakeExternalPtr(gfile, sym_mongo_gridfile, R_NilValue);
PROTECT(ptr);
R_RegisterCFinalizerEx(ptr, mongoGridfileFinalizer, TRUE);
setAttrib(ret, sym_mongo_gridfile, ptr);
PROTECT(cls = allocVector(STRSXP, 1));
SET_STRING_ELT(cls, 0, mkChar("mongo.gridfile.writer"));
classgets(ret, cls);
gridfile_writer_init(gfile, _gfs, _remotename, _contenttype);
UNPROTECT(3);
return ret;
}
/* 'name' should be 1-element STRSXP or SYMSXP */
SEXP setAttrib(SEXP vec, SEXP name, SEXP val)
{
PROTECT(vec);
PROTECT(name);
if (isString(name))
name = install(translateChar(STRING_ELT(name, 0)));
if (val == R_NilValue) {
UNPROTECT(2);
return removeAttrib(vec, name);
}
/* We allow attempting to remove names from NULL */
if (vec == R_NilValue)
error(_("attempt to set an attribute on NULL"));
if (NAMED(val)) val = duplicate(val);
SET_NAMED(val, NAMED(val) | NAMED(vec));
UNPROTECT(2);
if (name == R_NamesSymbol)
return namesgets(vec, val);
else if (name == R_DimSymbol)
return dimgets(vec, val);
else if (name == R_DimNamesSymbol)
return dimnamesgets(vec, val);
else if (name == R_ClassSymbol)
return classgets(vec, val);
else if (name == R_TspSymbol)
return tspgets(vec, val);
else if (name == R_CommentSymbol)
return commentgets(vec, val);
else if (name == R_RowNamesSymbol)
return row_names_gets(vec, val);
else
return installAttrib(vec, name, val);
}
SEXP mongo_gridfs_create(SEXP mongo_conn, SEXP db, SEXP prefix) {
mongo* conn = _checkMongo(mongo_conn);
const char* _db = CHAR(STRING_ELT(db, 0));
const char* _prefix = CHAR(STRING_ELT(prefix, 0));
gridfs* gfs = Calloc(1, gridfs);
if (gridfs_init(conn, _db, _prefix, gfs) != MONGO_OK) {
Free(gfs);
return R_NilValue;
}
SEXP ret, ptr, cls;
PROTECT(ret = allocVector(INTSXP, 1));
INTEGER(ret)[0] = 0;
/* prevent GC on connection object while gfs alive */
setAttrib(ret, sym_mongo, mongo_conn);
ptr = R_MakeExternalPtr(gfs, sym_mongo_gridfs, R_NilValue);
PROTECT(ptr);
R_RegisterCFinalizerEx(ptr, mongoGridfsFinalizer, TRUE);
setAttrib(ret, sym_mongo_gridfs, ptr);
PROTECT(cls = allocVector(STRSXP, 1));
SET_STRING_ELT(cls, 0, mkChar("mongo.gridfs"));
classgets(ret, cls);
UNPROTECT(3);
return ret;
}
SEXP insnp_new(const SEXP Filenames, const SEXP Sample_id, const SEXP Snp_id,
const SEXP Diploid, const SEXP Fields,
const SEXP Codes, const SEXP Threshold, const SEXP Lower,
const SEXP Sep, const SEXP Comment, const SEXP Skip,
const SEXP Simplify, const SEXP Verbose,
const SEXP In_order, const SEXP Every){
/* Process arguments */
if (TYPEOF(Verbose)!=LGLSXP)
error("Argument type error: Verbose");
if (length(Verbose)>1)
warning("Only first element of argument used: Verbose");
int verbose = *INTEGER(Verbose);
if (TYPEOF(In_order)!=LGLSXP)
error("Argument type error: In_order");
if (length(In_order)>1)
warning("Only first element of argument used: In_order");
int in_order = *INTEGER(In_order);
if (TYPEOF(Filenames)!=STRSXP)
error("Argument type error: Filenames");
int Nfile = length(Filenames);
int Nsample=0;
if (TYPEOF(Sample_id)==STRSXP)
Nsample = length(Sample_id);
else if (TYPEOF(Sample_id)!=NILSXP)
error("Argument type error: Sample_id");
int Nsnp=0;
if (TYPEOF(Snp_id)==STRSXP)
Nsnp = length(Snp_id);
else if (TYPEOF(Snp_id)!=NILSXP)
error("Argument type error: Snp_id");
/* file is 1 = sample, 2 = snp, 0 = irrelevant */
int file_is = 0;
if (!Nsample) {
if (Nsnp) {
Nsample = Nfile;
Rprintf("Each file is assumed to concern a single sample\n");
Rprintf("(Sample IDs are assumed to be included in filenames)\n");
file_is = 1;
}
else
error("No sample or SNP IDs specified");
}
else if (!Nsnp) {
Nsnp = Nfile;
Rprintf("Each file is assumed to concern a single SNP\n");
Rprintf("(SNP IDs are assumed to be included in filenames)\n");
file_is = 2;
}
/* If not in order, set up hash tables */
index_db sample_index = NULL;
index_db snp_index = NULL;
if (!in_order) {
if (file_is != 1)
sample_index = create_name_index(Sample_id);
if (file_is != 2)
snp_index = create_name_index(Snp_id);
}
int *diploid=NULL;
if (TYPEOF(Diploid)==LGLSXP) {
if (length(Diploid)!=Nsample)
error("Argument length error: diploid argument");
diploid = LOGICAL(Diploid);
}
else if (TYPEOF(Diploid)!=NILSXP)
error("Argument type error: diploid argument");
if (TYPEOF(Fields)!=INTSXP)
error("Argument type error: Fields");
int *fields = INTEGER(Fields);
int fsamp=0, fsnp=0, fgt=0, fa1=0, fa2=0, fconf=0;
SEXP Fnames = getAttrib(Fields, R_NamesSymbol);
if (TYPEOF(Fnames)==NILSXP)
error("Argument error: Fields argument has no names");
int fmax = 0;
int Nfield = length(Fields);
for (int i=0; i<Nfield; i++) {
const char *fname = CHAR(STRING_ELT(Fnames, i));
int fi = fields[i];
if (!strcmp(fname, "sample"))
fsamp = fi;
else if (!strcmp(fname, "snp"))
fsnp = fi;
else if (!strcmp(fname, "genotype"))
fgt = fi;
else if (!strcmp(fname, "allele1"))
fa1 = fi;
else if (!strcmp(fname, "allele2"))
fa2 = fi;
else if (!strcmp(fname, "confidence"))
fconf = fi;
else
error("Unrecognized input field name: %s", fname);
if (fi>fmax)
fmax = fi;
}
if (verbose) {
Rprintf("Reading one call per input line\n");
if (fsamp) {
Rprintf(" Sample id is in field %d", fsamp);
if (file_is==1)
Rprintf(" (ignored)\n");
else
Rprintf("\n");
}
if (fsnp) {
Rprintf(" SNP id is in field %d", fsnp);
if (file_is==2)
Rprintf(" (ignored)\n");
else
Rprintf("\n");
}
if (fgt)
Rprintf(" Genotype is in field %d\n", fgt);
if (fa1)
Rprintf(" Allele 1 is in field %d\n", fa1);
if (fa2)
Rprintf(" Allele 2 is in field %d\n", fa2);
if (fconf)
Rprintf(" Confidence score is in field %d\n", fconf);
}
if (file_is==1)
fsamp = 0;
else if (file_is==2)
fsnp = 0;
/* Allele or genotype coding? */
int gcoding;
if (fgt) {
if (fa1 || fa2)
error("Coding must be by genotype OR allele, not both");
gcoding = 1;
}
else {
if (!(fa1 && fa2))
error("No genotype or allele field(s) specified");
if (!(fa1 && fa2))
error("Field positions for both alleles must be specified");
gcoding = 0;
}
int nuc = 0;
if (TYPEOF(Codes)!=STRSXP)
error("Argument type error: Codes");
if (length(Codes)==1) {
SEXP Code = STRING_ELT(Codes, 0);
const char *code = CHAR(Code);
if (!strcmp(code, "nucleotide"))
nuc = 1;
else
error("Unrecognized coding: %s", code);
}
else {
int ncode = length(Codes);
if (gcoding) {
if (diploid) {
if (ncode!=5) {
if (ncode==3)
warning("Genotype coding for X: haploid genotypes are assumed to be coded as homozygous");
else
error("Genotype coding for X.snp: three or five genotype codes must be specified");
}
}
else {
if (ncode!=3)
error("Genotype coding: three genotype codes must be specified");
}
}
else {
if (ncode!=2)
error("Allele coding: two allele codes must be specified");
}
}
if (TYPEOF(Threshold)==NILSXP && !fconf)
error("Argument type error: no threshold argument");
if (TYPEOF(Threshold)!=REALSXP)
error("Argument type error: Threshold");
double threshold = *REAL(Threshold);
if (fconf && threshold==NA_REAL)
error("Confidence score is read but no threshold is set");
if (TYPEOF(Lower)!=LGLSXP)
error("Argument type error: Lower");
if (length(Lower)>1)
warning("Only first element of argument used: Lower");
int lower = *INTEGER(Lower);
char sep = ' ';
if (TYPEOF(Sep)==STRSXP) {
if (length(Sep)>1)
warning("Only first element of argument used: Sep");
const char *c = CHAR(STRING_ELT(Sep, 0));
if (strlen(c)>1)
warning("Only first character used: Sep");
sep = c[0];
}
else if (TYPEOF(Sep)!=NILSXP)
error("Argument type error: Sep");
char comment = (char) 0;
if (TYPEOF(Comment)==STRSXP) {
if (length(Sep)>1)
warning("Only first element of argument used: Comment");
const char *c = CHAR(STRING_ELT(Comment, 0));
if (strlen(c)>1)
warning("Only first character used: Comment");
comment = c[0];
}
else if (TYPEOF(Comment)!=NILSXP)
error("Argument type error: Comment");
int skip = 0;
if (TYPEOF(Skip)==INTSXP) {
if (length(Skip)>1)
warning("Only first element used: Skip");
skip = INTEGER(Skip)[0];
}
else if (TYPEOF(Skip)!=NILSXP)
error("Argument type error: Skip");
if (TYPEOF(Simplify)!=LGLSXP)
error("Argument type error: Simplify");
if (length(Simplify)>2)
error("Argument length error: Simplify");
int *simplify = INTEGER(Simplify);
if (length(Simplify)==1)
simplify[1] = simplify[0];
int every=0;
if (TYPEOF(Every)==INTSXP) {
if (length(Every)>1)
warning("Only first element used: Every");
every = INTEGER(Every)[0];
}
else if (TYPEOF(Every)!=NILSXP)
error("Argument type error: Every");
/* Create output object and initialise to zero */
if (verbose) {
if (diploid)
Rprintf("Reading XSnpMatrix with %d rows and %d columns\n",
Nsample, Nsnp);
else
Rprintf("Reading SnpMatrix with %d rows and %d columns\n",
Nsample, Nsnp);
}
SEXP Result, Dimnames, Package, Class;
PROTECT(Result = allocMatrix(RAWSXP, Nsample, Nsnp));
PROTECT(Dimnames = allocVector(VECSXP, 2));
if (simplify[0]) {
SET_VECTOR_ELT(Dimnames, 0,
simplify_names(file_is==1? Filenames: Sample_id));
}
else {
SET_VECTOR_ELT(Dimnames, 0,
duplicate(file_is==1? Filenames: Sample_id));
}
if (simplify[1]) {
SET_VECTOR_ELT(Dimnames, 1,
simplify_names(file_is==2? Filenames: Snp_id));
}
else {
SET_VECTOR_ELT(Dimnames, 1,
duplicate(file_is==2? Filenames: Snp_id));
}
setAttrib(Result, R_DimNamesSymbol, Dimnames);
/* Class */
PROTECT(Class = allocVector(STRSXP, 1));
if (diploid) {
R_do_slot_assign(Result, mkString("diploid"), Diploid);
SET_STRING_ELT(Class, 0, mkChar("XSnpMatrix"));
}
else {
SET_STRING_ELT(Class, 0, mkChar("SnpMatrix"));
}
PROTECT(Package = allocVector(STRSXP, 1));
SET_STRING_ELT(Package, 0, mkChar("snpStats"));
setAttrib(Class, install("package"), Package);
classgets(Result, Class);
SET_S4_OBJECT(Result);
unsigned char *result = RAW(Result);
memset(result, 0x00, Nsample*Nsnp);
/* Read in data */
char field[MAX_FLD];
int Naccept = 0, Nreject = 0, Nocall = 0, Nskipped = 0, Nxerror = 0;
int i_this = 0, j_this = 0;
const char *this_sample=NULL, *this_snp=NULL;
if (fsamp) {
this_sample = CHAR(STRING_ELT(Sample_id, 0));
}
if (fsnp) {
this_snp = CHAR(STRING_ELT(Snp_id, 0));
}
if (verbose) {
Rprintf(" Cumulative totals\n");
Rprintf(" -----------------------------------\n");
Rprintf(" File Line Accepted Rejected No call Skipped File name\n");
}
/* slowest varying 0 = don't know, 1 = sample, 2 = snp */
int slowest = file_is, last=Nsample*Nsnp-1;
int advance = 0, finished=0;
for (int f=0; f<Nfile; f++) {
/* Open input file */
const char *filename = CHAR(STRING_ELT(Filenames, f));
if (verbose) {
int lfn = strlen(filename);
if (lfn > 20) {
Rprintf("%59s...%-17s\r", "", filename+lfn-17);
}
else
Rprintf("%59s%-20s\r", "", filename);
}
gzFile infile = gzopen(filename, "rb");
if (!infile) {
warning("Failure to open input file: %s", filename);
continue;
}
int fterm = 2, line = 0, found_in_file = 0;
/* Skip any header lines */
for (int i=0; i<skip; i++) {
line++;
if (skip_to_eol(infile)==3)
error("End-of-file reached on line %d", line);
}
Nskipped += skip;
/* Read data lines */
while (fterm!=3) {
/* Read a line */
line++;
if (verbose && every && !(line % every))
Rprintf("%8d %8d %10d %8d %8d %8d\r",
f+1, line, Naccept, Nreject, Nocall, Nskipped);
int genotype=0, allele1=0, allele2=0;
/* wanted is coded as:
1 if this call is to be accepted
0 if it is not wanted (or a comment line)
-1 if rejected due to insufficient confidence
-2 coded as no-call
*/
int wanted = 1;
char sampid[MAX_FLD], snpid[MAX_FLD];
char gtype1[MAX_FLD], gtype2[MAX_FLD];
char cscore[MAX_FLD];
sampid[0] = snpid[0] = cscore[0] = (char) 0;
for (int r=1; (r<=fmax); r++) {
fterm = next_field(infile, sep, comment, '_', field, MAX_FLD);
if (!fterm)
error("Field overflow: line %d, field %d", line, r);
if ((fterm>1) && (r<fmax)) {
if (r==1) {
if(!field[0]) {
/* Empty line or comment line */
wanted = 0;
if (fterm==2) {
Nskipped++;
continue;
}
else
break;
}
}
error("Incomplete line: %d (last field read: %d = %s)",
line, r, field);
}
/* Save fields */
if (r==fsamp) {
strncpy(sampid, field, MAX_FLD-1);
}
else if (r==fsnp) {
strncpy(snpid, field, MAX_FLD-1);
}
else if (r==fconf) {
strncpy(cscore, field, MAX_FLD-1);
}
else if (r==fgt)
strncpy(gtype1, field, MAX_FLD-1);
else if (r==fa1)
strncpy(gtype1, field, MAX_FLD-1);
else if (r==fa2)
strncpy(gtype2, field, MAX_FLD-1);
else {
/* skip field */
}
} /* Matches: for (int r=1; (r<=fmax); r++) { */
if (!wanted)
continue;
/* Discard any further fields */
if (fterm<2) {
fterm = skip_to_eol(infile);
}
/* Find next target and check matches */
int match_sample, match_snp;
if (in_order) {
/* Advance to next target read */
if (advance) {
/*
If unknown, determine sort order by seeing which indicator
has changed
*/
if (!slowest) {
if (strcmp(this_sample, sampid))
slowest = 2; /* sample fastest, SNP slowest */
else if (strcmp(this_snp, snpid))
slowest = 1; /* SNP fastest, sample slowest */
else
error("Error in input file sort order");
}
/* Now advance fastest varying indicator */
if (slowest==1) {
j_this++;
if (j_this==Nsnp) {
j_this = 0;
if (fsamp) {
i_this++;
if (i_this==Nsample) {
finished = 1;
break;
}
else
this_sample = CHAR(STRING_ELT(Sample_id, i_this));
}
}
this_snp = CHAR(STRING_ELT(Snp_id, j_this));
}
else {
i_this++;
if (i_this==Nsample) {
i_this = 0;
if (fsnp) {
j_this++;
if (j_this==Nsnp) {
finished = 1;
break;
}
else
this_snp = CHAR(STRING_ELT(Snp_id, j_this));
}
}
this_sample = CHAR(STRING_ELT(Sample_id, i_this));
}
}
/* Does current line match current target? */
match_sample = file_is==1 || !strcmp(this_sample, sampid);
match_snp = file_is==2 || !strcmp(this_snp, snpid);
}
else { /* Not in order */
if (file_is!=1) {
if (this_sample && strcmp(this_sample, sampid))
i_this = index_lookup(sample_index, sampid);
if (i_this >= 0) {
this_sample = CHAR(STRING_ELT(Sample_id, i_this));
match_sample = 1;
}
else {
this_sample = NULL;
match_sample = 0;
}
}
else {
match_sample = 1;
i_this = f;
}
if (file_is!=2) {
if (this_snp && strcmp(this_snp, snpid))
j_this = index_lookup(snp_index, snpid);
if (j_this >= 0) {
this_snp = CHAR(STRING_ELT(Snp_id, j_this));
match_snp = 1;
}
else {
this_snp = NULL;
match_snp = 0;
}
}
else {
match_snp = 1;
j_this = f;
}
}
if (match_sample && match_snp) {
/* Next target read found in file(s) */
found_in_file++;
int ij_this = j_this*Nsample + i_this;
finished = (ij_this==last);
/* Check confidence score */
if (fconf) {
double conf;
if (sscanf(cscore, "%lf", &conf)!=1)
error("Failure to read confidence score: line %d", line);
if ((lower && conf<threshold) || (!lower && conf>threshold)) {
wanted = -1;
Nreject++;
if (finished)
break;
else
advance = 1;
continue;
}
}
/* Decode genotype */
int which;
if (gcoding) {
if (nuc) {
switch (strlen(gtype1)) {
case 0:
allele1 = allele2 = 0;
break;
case 1:
allele1 = allele2 = nucleotide(gtype1[0]);
break;
case 2:
allele1 = nucleotide(gtype1[0]);
allele2 = nucleotide(gtype1[1]);
break;
default:
error("Nucleotide coded genotype should be 2 character string: line %d", line);
}
}
else {
which = str_inlist(Codes, gtype1);
if (!which)
genotype = 0;
else if (which>3)
genotype = 2*which - 7;
else
genotype = which;
}
}
else {
if (nuc) {
allele1 = nucleotide(gtype1[0]);
allele2 = nucleotide(gtype2[0]);
}
else {
allele1 = str_inlist(Codes, gtype1);
allele2 = str_inlist(Codes, gtype2);
}
}
/* Successful read, store genotype in result[i_this, j_this] */
if (nuc || !gcoding) {
if (allele2 < allele1) {
genotype = allele2;
allele2 = allele1;
allele1 = genotype;
}
if (allele1 && allele2)
genotype = allele1 + (allele2*(allele2-1))/2;
else
genotype = 0;
}
if (genotype) {
if (diploid && !diploid[i_this] && (genotype==2))
Nxerror++;
else {
Naccept++;
result[ij_this] = (unsigned char) genotype;
}
}
else {
wanted = -2;
Nocall++;
}
/* Flag need to advance to next target */
advance = 1;
} /* matches if (match_sample && match_snp) { */
else {
Nskipped++;
/* Flag no advance to next target */
advance = 0;
}
if (finished)
break;
} /* matches: while (fterm!=3) { */
if (file_is==1)
i_this++;
if (file_is==2)
j_this++;
if (verbose) {
Rprintf("%8d %8d %10d %8d %8d %8d\r", f+1, line, Naccept, Nreject, Nocall, Nskipped);
}
if(!found_in_file)
warning("No calls found in file %s", filename);
gzclose(infile);
if (finished)
break;
}
/* Warnings */
if (in_order && !finished)
warning("End of data reached before search completed");
if (Nxerror)
warning("%d haploid genotypes were coded as heterozygous; set to NA", Nxerror);
if (Nskipped)
warning("%d lines of input file(s) were skipped", Nskipped);
/* Report */
if (verbose)
Rprintf("\n");
Rprintf("%d genotypes successfully read\n", Naccept);
if (Nreject)
Rprintf("%d genotypes were rejected due to low confidence\n", Nreject);
if (Nocall)
Rprintf("%d genotypes were not called\n", Nocall);
if (Nsample*Nsnp > Naccept+Nxerror+Nreject+Nocall)
Rprintf("%d genotypes could not be found on input file(s)\n",
Nsample*Nsnp - Naccept - Nreject - Nxerror-Nocall);
if (nuc) {
if (verbose)
Rprintf("Recasting and checking nucleotide coding\n");
int none_snps = recode_snp(result, Nsample, Nsnp);
if (none_snps) {
Rprintf("%d polymorphisms were not SNPs and have been set to NA ",
none_snps);
Rprintf("(see warnings for details)\n");
}
}
UNPROTECT(4);
/* Destroy hash indexes */
if (sample_index)
index_destroy(sample_index);
if (snp_index)
index_destroy(snp_index);
return Result;
}
SEXP df_split(SEXP s, SEXP sSep, SEXP sNamesSep, SEXP sResilient, SEXP sNcol,
SEXP sWhat, SEXP sColNames, SEXP sSkip, SEXP sNlines, SEXP sQuote) {
char sep;
int nsep, use_ncol, resilient, ncol;
long i, j, k, m, len, nmsep_flag, skip, quoteLen;
unsigned long nrow;
char num_buf[48];
const char *c, *c2, *sraw = 0, *send = 0, *quoteChars;
long nlines = asLong(sNlines, -1);
SEXP sOutput, tmp, sOutputNames, st, clv;
/* Parse inputs */
sep = CHAR(STRING_ELT(sSep, 0))[0];
nsep = (TYPEOF(sNamesSep) == STRSXP && LENGTH(sNamesSep) > 0) ? ((int) (unsigned char) *CHAR(STRING_ELT(sNamesSep, 0))) : -1;
nmsep_flag = (nsep > 0);
use_ncol = asInteger(sNcol);
resilient = asInteger(sResilient);
ncol = use_ncol; /* NOTE: "character" is prepended by the R code if nmsep is TRUE,
so ncol *does* include the key column */
skip = asLong(sSkip, 0);
/* parse quote information */
quoteChars = CHAR(STRING_ELT(sQuote, 0));
quoteLen = strlen(quoteChars);
/* count non-NA columns */
for (i = 0; i < use_ncol; i++)
if (TYPEOF(VECTOR_ELT(sWhat,i)) == NILSXP) ncol--;
/* check input */
if (TYPEOF(s) == RAWSXP) {
nrow = (nlines >= 0) ? count_lines_bounded(s, nlines + skip) : count_lines(s);
sraw = (const char*) RAW(s);
send = sraw + XLENGTH(s);
if (nrow >= skip) {
unsigned long slen = XLENGTH(s);
nrow = nrow - skip;
i = 0;
while (i < skip && (sraw = memchr(sraw, '\n', slen))) { sraw++; i++; }
} else {
nrow = 0;
sraw = send;
}
} else if (TYPEOF(s) == STRSXP) {
nrow = XLENGTH(s);
if (nrow >= skip) {
nrow -= skip;
} else {
skip = nrow;
nrow = 0;
}
} else
Rf_error("invalid input to split - must be a raw or character vector");
if (nlines >= 0 && nrow > nlines) nrow = nlines;
/* allocate result */
PROTECT(sOutput = allocVector(VECSXP, ncol));
/* set names */
setAttrib(sOutput, R_NamesSymbol, sOutputNames = allocVector(STRSXP, ncol));
if (nrow > INT_MAX)
Rf_warning("R currently doesn't support large data frames, but we have %lu rows, returning a named list instead", nrow);
else {
/* set automatic row names */
PROTECT(tmp = allocVector(INTSXP, 2));
INTEGER(tmp)[0] = NA_INTEGER;
INTEGER(tmp)[1] = -nrow;
setAttrib(sOutput, R_RowNamesSymbol, tmp);
UNPROTECT(1);
/* set class */
classgets(sOutput, mkString("data.frame"));
}
/* Create SEXP for each element of the output */
j = 0;
for (i = 0; i < use_ncol; i++) {
if (TYPEOF(VECTOR_ELT(sWhat,i)) != NILSXP) /* copy col.name */
SET_STRING_ELT(sOutputNames, j, STRING_ELT(sColNames, i));
switch (TYPEOF(VECTOR_ELT(sWhat,i))) {
case LGLSXP:
case INTSXP:
case REALSXP:
case CPLXSXP:
case STRSXP:
case RAWSXP:
SET_VECTOR_ELT(sOutput, j++, allocVector(TYPEOF(VECTOR_ELT(sWhat,i)), nrow));
break;
case VECSXP:
SET_VECTOR_ELT(sOutput, j++, st = allocVector(REALSXP, nrow));
clv = PROTECT(allocVector(STRSXP, 2));
SET_STRING_ELT(clv, 0, mkChar("POSIXct"));
SET_STRING_ELT(clv, 1, mkChar("POSIXt"));
setAttrib(st, R_ClassSymbol, clv);
/* this is somewhat a security precaution such that users
don't get surprised -- if there is no TZ R will
render it in local time - which is correct but
may confuse people that didn't use GMT to start with */
setAttrib(st, install("tzone"), mkString("GMT"));
UNPROTECT(1);
break;
case NILSXP:
break;
default:
Rf_error("Unsupported input to what %u.", TYPEOF(VECTOR_ELT(sWhat,i)));
break;
}
}
/* Cycle through the rows and extract the data */
for (k = 0; k < nrow; k++) {
const char *l = 0, *le;
if (TYPEOF(s) == RAWSXP) {
l = sraw;
le = memchr(l, '\n', send - l);
if (!le) le = send;
sraw = le + 1;
if (*(le - 1) == '\r' ) le--; /* account for DOS-style '\r\n' */
} else {
l = CHAR(STRING_ELT(s, k + skip));
le = l + strlen(l); /* probably lame, but using strings is way inefficient anyway ;) */
}
if (nmsep_flag) {
c = memchr(l, nsep, le - l);
if (c) {
SET_STRING_ELT(VECTOR_ELT(sOutput, 0), k, Rf_mkCharLen(l, c - l));
l = c + 1;
} else
SET_STRING_ELT(VECTOR_ELT(sOutput, 0), k, R_BlankString);
}
i = nmsep_flag;
j = nmsep_flag;
while (l < le) {
if (!(c = memchr(l, sep, le - l)))
c = le;
if (i >= use_ncol) {
if (resilient) break;
Rf_error("line %lu: too many input columns (expected %u)", k, use_ncol);
}
switch(TYPEOF(VECTOR_ELT(sWhat,i))) { // NOTE: no matching case for NILSXP
case LGLSXP:
len = (int) (c - l);
if (len > sizeof(num_buf) - 1)
len = sizeof(num_buf) - 1;
memcpy(num_buf, l, len);
num_buf[len] = 0;
int tr = StringTrue(num_buf), fa = StringFalse(num_buf);
LOGICAL(VECTOR_ELT(sOutput, j))[k] = (tr || fa) ? tr : NA_INTEGER;
j++;
break;
case INTSXP:
len = (int) (c - l);
/* watch for overflow and truncate -- should we warn? */
if (len > sizeof(num_buf) - 1)
len = sizeof(num_buf) - 1;
memcpy(num_buf, l, len);
num_buf[len] = 0;
INTEGER(VECTOR_ELT(sOutput, j))[k] = Strtoi(num_buf, 10);
j++;
break;
case REALSXP:
len = (int) (c - l);
/* watch for overflow and truncate -- should we warn? */
if (len > sizeof(num_buf) - 1)
len = sizeof(num_buf) - 1;
memcpy(num_buf, l, len);
num_buf[len] = 0;
REAL(VECTOR_ELT(sOutput, j))[k] = R_atof(num_buf);
j++;
break;
case CPLXSXP:
len = (int) (c - l);
/* watch for overflow and truncate -- should we warn? */
if (len > sizeof(num_buf) - 1)
len = sizeof(num_buf) - 1;
memcpy(num_buf, l, len);
num_buf[len] = 0;
COMPLEX(VECTOR_ELT(sOutput, j))[k] = strtoc(num_buf, TRUE);
j++;
break;
case STRSXP:
c2 = c;
if (quoteLen) {
for (m = 0; m < quoteLen; m++) {
if (*l == quoteChars[m]) {
l++;
if (!(c2 = memchr(l, quoteChars[m], le - l))) {
Rf_error("End of line within quoted string.");
} else {
if (!(c = memchr(c2, (unsigned char) sep, le - c2)))
c = le;
}
}
}
}
SET_STRING_ELT(VECTOR_ELT(sOutput, j), k, Rf_mkCharLen(l, c2 - l));
j++;
break;
case RAWSXP:
len = (int) (c - l);
/* watch for overflow and truncate -- should we warn? */
if (len > sizeof(num_buf) - 1)
len = sizeof(num_buf) - 1;
memcpy(num_buf, l, len);
num_buf[len] = 0;
RAW(VECTOR_ELT(sOutput, j))[k] = strtoraw(num_buf);
j++;
break;
case VECSXP:
REAL(VECTOR_ELT(sOutput, j))[k] = parse_ts(l, c);
j++;
}
l = c + 1;
i++;
}
/* fill-up unused columns */
while (i < use_ncol) {
switch (TYPEOF(VECTOR_ELT(sWhat,i))) { // NOTE: no matching case for NILSXP
case LGLSXP:
LOGICAL(VECTOR_ELT(sOutput, j++))[k] = NA_INTEGER;
break;
case INTSXP:
INTEGER(VECTOR_ELT(sOutput, j++))[k] = NA_INTEGER;
break;
case REALSXP:
case VECSXP:
REAL(VECTOR_ELT(sOutput, j++))[k] = NA_REAL;
break;
case CPLXSXP:
COMPLEX(VECTOR_ELT(sOutput, j))[k].r = NA_REAL;
COMPLEX(VECTOR_ELT(sOutput, j++))[k].i = NA_REAL;
break;
case STRSXP:
SET_STRING_ELT(VECTOR_ELT(sOutput, j++), k, R_NaString);
break;
case RAWSXP:
RAW(VECTOR_ELT(sOutput, j))[k] = (Rbyte) 0;
break;
}
i++;
}
}
UNPROTECT(1); /* sOutput */
return(sOutput);
}
/*then returns an R data.frame that contain the RRA values fitting between timestamps startIn (non incl) and sendIn*/
SEXP importRRD(SEXP filenameIn, SEXP cfIn, SEXP startIn, SEXP endIn, SEXP stepIn) {
rrd_value_t *data;
const char *filename;
const char *cf;
char** ds_namv;
time_t start;
time_t end;
unsigned long step;
unsigned long ds_cnt;
int status;
int size;
int ds;
int i;
int timeStamp;
SEXP out;
SEXP vec;
SEXP nam;
SEXP rowNam;
SEXP cls;
filename = CHAR(asChar(filenameIn));
if (access(filename, F_OK) == -1) {
printf("file does not exist\n");
exit(0);
}
cf = CHAR(asChar(cfIn));
start = (time_t) asInteger(startIn);
end = (time_t) asInteger(endIn);
step = (unsigned long) asInteger(stepIn);
printf("calling rrdfetch\n");
status = rrd_fetch_r(filename, cf, &start, &end, &step, &ds_cnt, &ds_namv, &data);
if (status != 0 || data == NULL) {
printf("error running rrd_fetch_r\n");
if (data)
free(data);
if (ds_namv) {
for (int k = 0; k < sizeof(ds_namv)/sizeof(char*); k++) {
free(ds_namv[k]);
}
free(ds_namv);
}
exit(0);
}
printf("size of data %d start %d end %d step %d ds_cnt %d\n", sizeof(data)/sizeof(rrd_value_t), start, end, step, ds_cnt);
//turns out rrd_fetch does not include start in data
size = (end - start)/step - 1;
out = PROTECT(allocVector(VECSXP, ds_cnt + 1) );
vec = PROTECT(allocVector(INTSXP, size));
PROTECT(rowNam = allocVector(STRSXP, size));
//turns out rrd_fetch does not include start in data
timeStamp = start + step;
for (i = 0; i < size; i++) {
INTEGER(vec)[i] = timeStamp;
timeStamp += step;
}
SET_VECTOR_ELT(out, 0, vec);
setAttrib(out, R_RowNamesSymbol, vec);
PROTECT(nam = allocVector(STRSXP, ds_cnt + 1));
SET_STRING_ELT(nam, 0, mkChar("timestamp"));
for (ds = 0; ds < ds_cnt; ds++){
SET_STRING_ELT(nam, ds + 1, mkChar(ds_namv[ds]));
vec = PROTECT(allocVector(REALSXP, size));
for (i = 0; i < size; i++){
/*printf("iterating.. i = %d\n", i);*/
REAL(vec)[i] = data[ds + i*ds_cnt];
}
SET_VECTOR_ELT(out, ds + 1, vec);
}
PROTECT(cls = allocVector(STRSXP, 1)); // class attribute
SET_STRING_ELT(cls, 0, mkChar("data.frame"));
classgets(out, cls);
namesgets(out, nam);
free(data);
for (int k = 0; k < sizeof(ds_namv)/sizeof(char*); k++) {
free(ds_namv[k]);
}
free(ds_namv);
UNPROTECT(ds_cnt + 4);
return out;
}
SEXP smartImportRRD(SEXP filenameIn){
time_t first;
time_t last;
time_t start;
time_t end;
time_t *startAr;
unsigned long curStep;
unsigned long ds_cnt;
unsigned long step;
int rraCnt;
int status;
int size;
int i;
int ds;
int j;
int timeStamp;
char **ds_namv;
const char *filename;
rrd_value_t *data;
rraInfo* rraInfoList;
rraInfo* rraInfoTmp;
rrd_info_t *rrdInfo;
SEXP out;
SEXP vec;
SEXP rraSexpList;
SEXP rraNames;
SEXP nam;
SEXP rowNam;
SEXP cls;
filename = CHAR(asChar(filenameIn));
if (access(filename, F_OK) == -1) {
printf("file does not exist\n");
exit(0);
}
printf("calling rrd_last\n");
last = rrd_last_r(filename);
printf("calling rrd_info\n");
rrdInfo = rrd_info_r(filename);
if (rrdInfo == NULL) {
printf("getting rrd info failed");
exit(0);
}
printf("calling getrrainfo\n");
rraInfoList = getRraInfo(rrdInfo, &rraCnt, &step);
if (rraInfoList == NULL) {
printf("getting rra info failed\n");
free(rrdInfo);
exit(0);
}
printf("rraCnt %d step %d last %d rraInfoList %p\n", rraCnt, step, last, rraInfoList);
printRraInfo(rraInfoList);
startAr = malloc(rraCnt * sizeof(time_t));
if (startAr == NULL) {
printf("memory allocation error");
free(rrdInfo);
freeRraInfo(rraInfoList);
exit(0);
}
for (i = 0; i < rraCnt; i++) {
startAr[i] = rrd_first_r(filename, i);
}
rraInfoTmp = rraInfoList;
PROTECT(rraNames = allocVector(STRSXP, rraCnt));
PROTECT(cls = allocVector(STRSXP, 1)); // class attribute
SET_STRING_ELT(cls, 0, mkChar("data.frame"));
out = PROTECT(allocVector(VECSXP, rraCnt));
i = 0;
printf("entering loop\n");
while (rraInfoTmp) {
start = startAr[i];
end = last;
curStep = step * rraInfoTmp->perRow;
status = rrd_fetch_r(filename, rraInfoTmp->cf, &start, &end, &curStep, &ds_cnt, &ds_namv, &data);
if (status != 0 || data == NULL) {
printf("error running rrd_fetch_r\n");
free(rrdInfo);
freeRraInfo(rraInfoList);
free(startAr);
if (data)
free(data);
if (ds_namv) {
for (int k = 0; k < sizeof(ds_namv)/sizeof(char*); k++) {
free(ds_namv[k]);
}
free(ds_namv);
}
//TODO unprotect how many times?
exit(0);
}
printf("size of data %d start %d end %d step %d ds_cnt %d\n", sizeof(data)/sizeof(rrd_value_t), start, end, curStep, ds_cnt);
fflush(stdout);
//rrd_fetch does not include start
size = (end - start)/curStep - 1;
printf("size %d\n", size);
rraSexpList = PROTECT(allocVector(VECSXP, ds_cnt + 1));
vec = PROTECT(allocVector(INTSXP, size));
PROTECT(rowNam = allocVector(STRSXP, size));
//rrd_fetch does not include start
timeStamp = start + curStep;
for (int j = 0; j < size; j++) {
INTEGER(vec)[j] = timeStamp;
timeStamp += curStep;
}
printf("setting row names\n");
SET_VECTOR_ELT(rraSexpList, 0, vec);
setAttrib(rraSexpList, R_RowNamesSymbol, vec);
PROTECT(nam = allocVector(STRSXP, ds_cnt + 1));
SET_STRING_ELT(nam, 0, mkChar("timestamp"));
//TODO stick to row/columns convention
for (ds = 0; ds < ds_cnt; ds++){
SET_STRING_ELT(nam, ds + 1, mkChar(ds_namv[ds]));
vec = PROTECT(allocVector(REALSXP, size));
for (j = 0; j < size; j++){
REAL(vec)[j] = data[ds + j*ds_cnt];
}
printf("adding ds vector to data frame\n");
SET_VECTOR_ELT(rraSexpList, ds + 1, vec);
}
classgets(rraSexpList, cls);
namesgets(rraSexpList, nam);
printf("adding data frame to out\n");
SET_VECTOR_ELT(out, i, rraSexpList);
char rraNameString[80];
char stepString[40];
sprintf(stepString, "%d", curStep);
strcpy(rraNameString, rraInfoTmp->cf);
strcat(rraNameString, stepString);
SET_STRING_ELT(rraNames, i, mkChar(rraNameString));
rraInfoTmp = rraInfoTmp->next;
i++;
free(data);
}
setAttrib(out, R_NamesSymbol, rraNames);
freeRraInfo(rraInfoList);
free(startAr);
free(rrdInfo);
for (int k = 0; k < sizeof(ds_namv)/sizeof(char*); k++) {
free(ds_namv[k]);
}
free(ds_namv);
UNPROTECT((ds_cnt + 2)*rraCnt + 3);
return out;
}
/* create integer rle
NOTE if rle is not efficient we return NULL instead of an rle object
*/
SEXP int_rle(SEXP x_)
{
register int lv,ln,i,c=0;
int n2, n = LENGTH(x_);
if (n<3)
return R_NilValue;
n2 = n / 3; /* xx max RAM requirement 2x, but rle only if at least 2/3 savings, using 2 instead of 3 would need 50% more time, have max RAM requirement 2.5x for savings of any size */
int *x = INTEGER(x_);
int *val, *len, *values, *lengths;
SEXP ret_, lengths_, values_, names_, class_;
val = Calloc(n2, int);
len = Calloc(n2, int);
if (n){
lv = x[0];
ln = 1;
for (i=1;i<n;i++){
if (x[i]==lv){
ln++;
}else{
val[c] = lv;
len[c] = ln;
c++;
if (c==n2){
Free(val);
Free(len);
return R_NilValue;
}
lv = x[i];
ln = 1;
}
}
val[c] = lv;
len[c] = ln;
c++;
}
PROTECT( values_ = allocVector(INTSXP, c) );
values = INTEGER(values_);
for (i=0;i<c;i++)
values[i] = val[i];
Free(val);
PROTECT( lengths_ = allocVector(INTSXP, c) );
lengths = INTEGER(lengths_);
for (i=0;i<c;i++)
lengths[i] = len[i];
Free(len);
PROTECT( ret_ = allocVector(VECSXP, 2) );
PROTECT( names_ = allocVector(STRSXP, 2));
PROTECT( class_ = allocVector(STRSXP, 1));
SET_STRING_ELT(names_, 0, mkChar("lengths"));
SET_STRING_ELT(names_, 1, mkChar("values"));
SET_STRING_ELT(class_, 0, mkChar("rle"));
SET_VECTOR_ELT(ret_, 0, lengths_);
SET_VECTOR_ELT(ret_, 1, values_);
setAttrib(ret_, R_NamesSymbol, names_);
classgets(ret_, class_);
UNPROTECT(5);
return ret_;
}
