SEXP read_bamfile_header(SEXP ext, SEXP what)
{
_checkext(ext, BAMFILE_TAG, "scanBamHeader");
if (!(IS_LOGICAL(what) && (2L == LENGTH(what))))
Rf_error("'what' must be logical(2)");
if (!LOGICAL(bamfile_isopen(ext))[0])
Rf_error("open() BamFile before reading header");
return _read_bam_header(ext, what);
}
SEXP prefilter_bamfile(SEXP ext, SEXP space, SEXP keepFlags,
SEXP isSimpleCigar, SEXP tagFilter, SEXP mapqFilter,
SEXP yieldSize, SEXP obeyQname, SEXP asMates,
SEXP qnamePrefixEnd, SEXP qnameSuffixStart)
{
_checkext(ext, BAMFILE_TAG, "filterBam");
_checkparams(space, keepFlags, isSimpleCigar);
if (!(IS_INTEGER(yieldSize) && (1L == LENGTH(yieldSize))))
Rf_error("'yieldSize' must be integer(1)");
if (!(IS_LOGICAL(obeyQname) && (1L == LENGTH(obeyQname))))
Rf_error("'obeyQname' must be logical(1)");
if (!(IS_LOGICAL(asMates) && (1L == LENGTH(asMates))))
Rf_error("'asMates' must be logical(1)");
SEXP result =
_prefilter_bam(ext, space, keepFlags, isSimpleCigar, tagFilter,
mapqFilter, yieldSize, obeyQname, asMates,
qnamePrefixEnd, qnameSuffixStart);
if (R_NilValue == result)
Rf_error("'filterBam' failed during pre-filtering");
return result;
}
SEXP
plr_SPI_cursor_fetch(SEXP cursor_in,SEXP forward_in, SEXP rows_in)
{
Portal portal=NULL;
int ntuples;
SEXP result = NULL;
MemoryContext oldcontext;
int forward;
int rows;
PREPARE_PG_TRY;
PUSH_PLERRCONTEXT(rsupport_error_callback, "pg.spi.cursor_fetch");
portal = R_ExternalPtrAddr(cursor_in);
if(!IS_LOGICAL(forward_in))
{
error("pg.spi.cursor_fetch arg2 must be boolean");
return result;
}
if(!IS_INTEGER(rows_in))
{
error("pg.spi.cursor_fetch arg3 must be an integer");
return result;
}
forward = LOGICAL_DATA(forward_in)[0];
rows = INTEGER_DATA(rows_in)[0];
/* switch to SPI memory context */
oldcontext = MemoryContextSwitchTo(plr_SPI_context);
PG_TRY();
{
/* Open the cursor */
SPI_cursor_fetch(portal,forward,rows);
}
PLR_PG_CATCH();
PLR_PG_END_TRY();
/* back to caller's memory context */
MemoryContextSwitchTo(oldcontext);
/* check the result */
ntuples = SPI_processed;
if (ntuples > 0)
{
result = rpgsql_get_results(ntuples, SPI_tuptable);
SPI_freetuptable(SPI_tuptable);
}
else
result = R_NilValue;
POP_PLERRCONTEXT;
return result;
}
SEXP scan_bamfile(SEXP ext, SEXP space, SEXP keepFlags, SEXP isSimpleCigar,
SEXP tagFilter, SEXP mapqFilter, SEXP reverseComplement,
SEXP yieldSize,
SEXP template_list, SEXP obeyQname, SEXP asMates,
SEXP qnamePrefixEnd, SEXP qnameSuffixStart)
{
_checkext(ext, BAMFILE_TAG, "scanBam");
_checkparams(space, keepFlags, isSimpleCigar);
if (!(IS_LOGICAL(reverseComplement) && (1L == LENGTH(reverseComplement))))
Rf_error("'reverseComplement' must be logical(1)");
if (!(IS_INTEGER(yieldSize) && (1L == LENGTH(yieldSize))))
Rf_error("'yieldSize' must be integer(1)");
if (!(IS_LOGICAL(obeyQname) && (1L == LENGTH(obeyQname))))
Rf_error("'obeyQname' must be logical(1)");
if (!(IS_LOGICAL(asMates) && (1L == LENGTH(asMates))))
Rf_error("'asMates' must be logical(1)");
_bam_check_template_list(template_list);
return _scan_bam(ext, space, keepFlags, isSimpleCigar,
tagFilter, mapqFilter, reverseComplement, yieldSize,
template_list, obeyQname, asMates, qnamePrefixEnd,
qnameSuffixStart);
}
double GetNumeric(SEXP p, double default_val, int* err_code){
if(p == R_NilValue){
if(err_code) *err_code = 1;
return default_val;
}else if(IS_INTEGER(p)){
return INTEGER(p)[0];
}else if(IS_LOGICAL(p)){
if(LOGICAL(p)[0]) return 1.0;
else return 0.0;
}else if(IS_NUMERIC(p)){
return REAL(p)[0];
}else{
if(err_code) *err_code = 2;
return default_val;
}
}
int GetInt(SEXP p, int default_val, int* err_code){
if(p == R_NilValue){
if(err_code) *err_code = 1;
return default_val;
}else if(IS_INTEGER(p)){
return INTEGER(p)[0];
}else if(IS_LOGICAL(p)){
if(LOGICAL(p)[0]) return 1;
else return 0;
}else if(IS_NUMERIC(p)){
return (int)(REAL(p)[0]);
}else{
if(err_code) *err_code = 2;
return default_val;
}
}
static int get_properties(SEXP nsend, SEXP nrecv, SEXP loops,
struct properties *p)
{
int xnsend, xnrecv, xloops;
/* validate and extract 'nsend' */
if (!IS_INTEGER(nsend) || LENGTH(nsend) != 1)
DOMAIN_ERROR("'nsend' should be a single integer");
xnsend = INTEGER_VALUE(nsend);
if (xnsend <= 0)
DOMAIN_ERROR("'nsend' should be positive");
/* validate and extract 'nrecv' */
if (!IS_INTEGER(nrecv) || LENGTH(nrecv) != 1)
DOMAIN_ERROR("'nrecv' should be a single integer");
xnrecv = INTEGER_VALUE(nrecv);
if (xnrecv <= 0)
DOMAIN_ERROR("'nrecv' should be positive");
/* validate and extract 'loops' */
if (!IS_LOGICAL(loops) || LENGTH(loops) != 1)
DOMAIN_ERROR("'loops' should be a single integer");
xloops = LOGICAL_VALUE(loops);
if (xloops == NA_LOGICAL)
DOMAIN_ERROR("'loops' must be TRUE or FALSE");
if (!xloops && xnrecv == 1)
DOMAIN_ERROR("'nrecv' should be at least 2 (no loops)");
p->nsend = (size_t)xnsend;
p->nrecv = (size_t)xnrecv;
p->exclude_loops = !xloops;
return 0;
}
void
plr_SPI_cursor_move(SEXP cursor_in,SEXP forward_in, SEXP rows_in)
{
Portal portal=NULL;
MemoryContext oldcontext;
int forward;
int rows;
PREPARE_PG_TRY;
PUSH_PLERRCONTEXT(rsupport_error_callback, "pg.spi.cursor_move");
portal = R_ExternalPtrAddr(cursor_in);
if(!IS_LOGICAL(forward_in))
{
error("pg.spi.cursor_move arg2 must be boolean");
return;
}
if(!IS_INTEGER(rows_in))
{
error("pg.spi.cursor_move arg3 must be an integer");
return;
}
forward = LOGICAL(forward_in)[0];
rows = INTEGER(rows_in)[0];
/* switch to SPI memory context */
oldcontext = MemoryContextSwitchTo(plr_SPI_context);
PG_TRY();
{
/* Open the cursor */
SPI_cursor_move(portal, forward, rows);
}
PLR_PG_CATCH();
PLR_PG_END_TRY();
/* back to caller's memory context */
MemoryContextSwitchTo(oldcontext);
}
SEXP rph_phyloFit(SEXP msaP,
SEXP treeStrP,
SEXP substModP,
SEXP scaleOnlyP,
SEXP scaleSubtreeP,
SEXP nratesP,
SEXP alphaP,
SEXP rateConstantsP,
SEXP initModP,
SEXP initBackgdFromDataP,
SEXP initRandomP,
SEXP initParsimonyP,
SEXP clockP,
SEXP emP,
SEXP maxEmItsP,
SEXP precisionP,
SEXP gffP,
SEXP ninfSitesP,
SEXP quietP,
SEXP noOptP,
SEXP boundP,
SEXP logFileP,
SEXP selectionP) {
struct phyloFit_struct *pf;
int numProtect=0, i;
double *doubleP;
char *die_message=NULL;
SEXP rv=R_NilValue;
List *new_rate_consts = NULL;
List *new_rate_weights = NULL;
GetRNGstate(); //seed R's random number generator
pf = phyloFit_struct_new(1); //sets appropriate defaults for RPHAST mode
pf->msa = (MSA*)EXTPTR_PTR(msaP);
if (treeStrP != R_NilValue)
pf->tree = rph_tree_new(treeStrP);
pf->use_em = LOGICAL_VALUE(emP);
if (rateConstantsP != R_NilValue) {
PROTECT(rateConstantsP = AS_NUMERIC(rateConstantsP));
numProtect++;
doubleP = NUMERIC_POINTER(rateConstantsP);
new_rate_consts = lst_new_dbl(LENGTH(rateConstantsP));
for (i=0; i < LENGTH(rateConstantsP); i++)
lst_push_dbl(new_rate_consts, doubleP[i]);
// pf->use_em = 1;
}
if (initModP != R_NilValue) {
pf->input_mod = (TreeModel*)EXTPTR_PTR(initModP);
pf->subst_mod = pf->input_mod->subst_mod;
tm_register_protect(pf->input_mod);
if (new_rate_consts == NULL && pf->input_mod->rK != NULL && pf->input_mod->nratecats > 1) {
new_rate_consts = lst_new_dbl(pf->input_mod->nratecats);
for (i=0; i < pf->input_mod->nratecats; i++)
lst_push_dbl(new_rate_consts, pf->input_mod->rK[i]);
// pf-> = 1;
}
if (pf->input_mod->empirical_rates && pf->input_mod->freqK != NULL && pf->input_mod->nratecats > 1) {
new_rate_weights = lst_new_dbl(pf->input_mod->nratecats);
for (i=0; i < pf->input_mod->nratecats; i++)
lst_push_dbl(new_rate_weights, pf->input_mod->freqK[i]);
}
tm_reinit(pf->input_mod,
rph_get_subst_mod(substModP),
nratesP == R_NilValue ? pf->input_mod->nratecats : INTEGER_VALUE(nratesP),
NUMERIC_VALUE(alphaP),
new_rate_consts,
new_rate_weights);
} else {
if (nratesP != R_NilValue)
pf->nratecats = INTEGER_VALUE(nratesP);
if (alphaP != R_NilValue)
pf->alpha = NUMERIC_VALUE(alphaP);
if (rateConstantsP != R_NilValue) {
pf->rate_consts = new_rate_consts;
if (nratesP == R_NilValue)
pf->nratecats = lst_size(new_rate_consts);
else if (lst_size(new_rate_consts) != pf->nratecats)
die("length of new_rate_consts does not match nratecats\n");
}
}
pf->subst_mod = rph_get_subst_mod(substModP);
pf->estimate_scale_only = LOGICAL_VALUE(scaleOnlyP);
if (scaleSubtreeP != R_NilValue) {
pf->subtree_name = smalloc((1+strlen(CHARACTER_VALUE(scaleSubtreeP)))*sizeof(char));
strcpy(pf->subtree_name, CHARACTER_VALUE(scaleSubtreeP));
}
pf->random_init = LOGICAL_VALUE(initRandomP);
pf->init_backgd_from_data = LOGICAL_VALUE(initBackgdFromDataP);
pf->init_parsimony = LOGICAL_VALUE(initParsimonyP);
pf->assume_clock = LOGICAL_VALUE(clockP);
if (maxEmItsP != R_NilValue)
pf->max_em_its = INTEGER_VALUE(maxEmItsP);
pf->precision = get_precision(CHARACTER_VALUE(precisionP));
if (pf->precision == OPT_UNKNOWN_PREC) {
die_message = "invalid precision";
goto rph_phyloFit_end;
}
if (gffP != R_NilValue) {
pf->gff = (GFF_Set*)EXTPTR_PTR(gffP);
gff_register_protect(pf->gff);
}
if (ninfSitesP != R_NilValue)
pf->nsites_threshold = INTEGER_VALUE(ninfSitesP);
pf->quiet = LOGICAL_VALUE(quietP);
if (noOptP != R_NilValue) {
int len=LENGTH(noOptP), pos=0;
char *temp;
for (i=0; i < LENGTH(noOptP); i++)
len += strlen(CHARACTER_VALUE(STRING_ELT(noOptP, i)));
temp = smalloc(len*sizeof(char));
for (i=0; i < LENGTH(noOptP); i++) {
if (i != 0) temp[pos++] = ',';
sprintf(&temp[pos], "%s", CHARACTER_VALUE(STRING_ELT(noOptP, i)));
pos += strlen(CHARACTER_VALUE(STRING_ELT(noOptP, i)));
}
if (pos != len-1) die("ERROR parsing noOpt len=%i pos=%i\n", len, pos);
temp[pos] = '\0';
pf->nooptstr = str_new_charstr(temp);
}
if (boundP != R_NilValue) {
pf->bound_arg = lst_new_ptr(LENGTH(boundP));
for (i=0; i < LENGTH(boundP); i++) {
String *temp = str_new_charstr(CHARACTER_VALUE(STRING_ELT(boundP, i)));
lst_push_ptr(pf->bound_arg, temp);
}
}
if (logFileP != R_NilValue) {
if (IS_CHARACTER(logFileP))
pf->logf = phast_fopen(CHARACTER_VALUE(logFileP), "w+");
else if (IS_LOGICAL(logFileP) &&
LOGICAL_VALUE(logFileP)) {
pf->logf = stdout;
}
}
if (selectionP != R_NilValue) {
pf->use_selection = TRUE;
pf->selection = NUMERIC_VALUE(selectionP);
}
msa_register_protect(pf->msa);
run_phyloFit(pf);
rv = PROTECT(rph_listOfLists_to_SEXP(pf->results));
numProtect++;
rph_phyloFit_end:
if (pf->logf != NULL && pf->logf != stdout && pf->logf != stderr)
phast_fclose(pf->logf);
PutRNGstate();
if (die_message != NULL) die(die_message);
if (numProtect > 0)
UNPROTECT(numProtect);
return rv;
}
SV *
toPerl(USER_OBJECT_ val, Rboolean perlOwned)
{
int n = GET_LENGTH(val);
dTHX;
SV *sv = &sv_undef;
if(val == NULL_USER_OBJECT)
return(sv);
if(isRSReferenceObject(val)){
return(getForeignPerlReference(val));
}
if(GET_LENGTH(GET_CLASS(val))) {
SV *o = userLevelConversionToPerl(val);
if(!o)
return(o);
}
if(n == 1) {
if(IS_CHARACTER(val))
sv = newSVpv(CHAR_DEREF(STRING_ELT(val, 0)), 0);
else if(IS_LOGICAL(val))
sv = newSViv(LOGICAL_DATA(val)[0]);
else if(IS_INTEGER(val))
sv = newSViv(INTEGER_DATA(val)[0]);
else if(IS_NUMERIC(val))
sv = newSVnv(NUMERIC_DATA(val)[0]);
else if(IS_FUNCTION(val))
sv = RPerl_createRProxy(val);
} else {
AV *arr;
int i;
arr = newAV();
SvREFCNT_inc(arr);
if(n > 0)
av_extend(arr, n);
/* Did try using av_make() and storing the SVs in an array first, but didn't fix the problem
of bizarre array.
*/
for(i = 0; i < n ; i++) {
if(IS_CHARACTER(val))
sv = newSVpv(CHAR_DEREF(STRING_ELT(val, i)), 0);
else if(IS_LOGICAL(val))
sv = newSViv(LOGICAL_DATA(val)[i]);
else if(IS_INTEGER(val))
sv = newSViv(INTEGER_DATA(val)[i]);
else if(IS_NUMERIC(val))
sv = newSVnv(NUMERIC_DATA(val)[i]);
SvREFCNT_inc(sv);
av_push(arr, sv);
}
sv = (SV *) arr;
SvREFCNT_dec(arr);
#if 0
{SV *rv = newSVrv(arr, NULL);
sv = rv;
}
#endif
}
if(perlOwned)
#if 0 /*XXX Just experimenting */
sv = sv_2mortal(sv);
#else
sv = SvREFCNT_inc(sv);
#endif
return(sv);
}