SEXP rph_tree_scale(SEXP treeStr, SEXP scaleP, SEXP nodeStr,
SEXP includeLeadingP) {
TreeNode *tr = rph_tree_new(treeStr);
double scale = NUMERIC_VALUE(scaleP);
char *newTreeStr;
SEXP result;
if (nodeStr != R_NilValue) {
TreeNode *n;
int includeLeading=LOGICAL_VALUE(includeLeadingP);
n = tr_get_node(tr, CHARACTER_VALUE(nodeStr));
if (n == NULL) {
tr_name_ancestors(tr);
n = tr_get_node(tr, CHARACTER_VALUE(nodeStr));
if (n == NULL)
die("No node named %s in %s\n", CHARACTER_VALUE(nodeStr),
CHARACTER_VALUE(treeStr));
}
tr_scale_subtree(tr, n, scale, includeLeading);
}
else tr_scale(tr, scale);
newTreeStr = tr_to_string(tr, 1);
PROTECT(result = NEW_CHARACTER(1));
SET_STRING_ELT(result, 0, mkChar(newTreeStr));
UNPROTECT(1);
return result;
}
SEXP estimate_trace(SEXP A, SEXP n, SEXP lambdamin, SEXP lambdamax, SEXP tol, SEXP samples, SEXP reqCores, SEXP rz, SEXP ans)
{
int i;
int nsamples;
double lmin, lmax;
double max_error;
int rows;
double *pA;
double *pans;
double *prz;
double sum=0;
SEXP list;
nsamples=INTEGER_VALUE(samples);
lmin=NUMERIC_VALUE(lambdamin);
lmax=NUMERIC_VALUE(lambdamax);
rows=INTEGER_VALUE(n);
max_error=NUMERIC_VALUE(tol);
PROTECT(A=AS_NUMERIC(A));
pA=NUMERIC_POINTER(A);
PROTECT(ans=AS_NUMERIC(ans));
pans=NUMERIC_POINTER(ans);
PROTECT(rz=AS_NUMERIC(rz));
prz=NUMERIC_POINTER(rz);
for(i=0; i<nsamples; i++)
{
sum+=Bai(pA,&rows,&lmin, &lmax, &max_error,prz,&i);
}
*pans=(sum/(nsamples));
PROTECT(list=allocVector(VECSXP,1));
SET_VECTOR_ELT(list,0,ans);
UNPROTECT(4);
return(list);
}
SEXP module3(SEXP num1, SEXP Nrim, SEXP Mdiscr, SEXP h, SEXP h_new, SEXP Sin, SEXP Sout, SEXP STin, SEXP STout, SEXP Freq_in, SEXP Freq_out, SEXP max_con, SEXP Cf_c, SEXP toll)
{
int nProtected = 0;
int num11, Nrim1, max_con1;
double Cf_c1;
MATRICEi *Mdiscr1;
VETTOREi *h1, *h_new1, *Sin1, *Sout1;
VETTOREd *STin1, *STout1, *Freq_in1, *Freq_out1, *toll1;
LISTA *l = NULL;
SEXP ris;
_InitDbg(false, false, false);
_Intestazione("\n*** module3 ***\n");
num11 = INTEGER_VALUE(num1);
Nrim1 = INTEGER_VALUE(Nrim);
Mdiscr1 = inMATRICE_i(Mdiscr, &nProtected);
h1 = inVETTORE_i(h, &nProtected);
h_new1 = inVETTORE_i(h_new, &nProtected);
Sin1 = inVETTORE_i(Sin, &nProtected);
Sout1 = inVETTORE_i(Sout, &nProtected);
STin1 = inVETTORE_d(STin, &nProtected);
STout1 = inVETTORE_d(STout, &nProtected);
Freq_in1 = inVETTORE_d(Freq_in, &nProtected);
Freq_out1 = inVETTORE_d(Freq_out, &nProtected);
max_con1 = INTEGER_VALUE(max_con);
Cf_c1 = NUMERIC_VALUE(Cf_c);
toll1 = inVETTORE_d(toll, &nProtected);
l = module31(l, num11, Nrim1, Mdiscr1, h1, h_new1, Sin1, Sout1, STin1, STout1, Freq_in1, Freq_out1, max_con1, Cf_c1, toll1);
ris = daLISTA(l, &nProtected);
CANCELLAv_i(h1);
CANCELLAv_i(h_new1);
CANCELLAv_i(Sin1);
CANCELLAv_i(Sout1);
CANCELLAm_i(Mdiscr1);
CANCELLAv_d(STin1);
CANCELLAv_d(Freq_in1);
CANCELLAv_d(Freq_out1);
CANCELLAv_d(STout1);
CANCELLAv_d(toll1);
StrBilanciam();
ControllaCanc();
UNPROTECT(nProtected);
return ris;
}
// From R, we transmit directly the values of parameters to C++. After to make calculations in C++
// we re-transmit result to R.
//
// m0: Average death rate and also Average birth rate
// beta0: Contact rate
// sigma0: Average latent period
// gamma0: Average infectious period
//
// Result: equilibrium values of S, E, I
SEXP getEquilibrium(SEXP mu0,SEXP beta0,SEXP sigma0,SEXP gamma0){
double mu, beta, gamma, sigma;
//convert the R value type to the C++ value type
mu = NUMERIC_VALUE(mu0);
beta = NUMERIC_VALUE(beta0);
sigma = NUMERIC_VALUE(sigma0);
gamma = NUMERIC_VALUE(gamma0);
//parameter holding result
SEXP rsei_eq;
double *csei_eq;
int len = 3;
// Allocating storage space:
PROTECT(rsei_eq = NEW_NUMERIC(len));
csei_eq = NUMERIC_POINTER(rsei_eq);
double sir_R0 = beta/(gamma+mu); // calculating the value of R0
if(sigma==INFINITY){// for SIR model,
if(sir_R0>1.0){
csei_eq[0] = 1/sir_R0;// equilibrium value of S
csei_eq[1] = 0.0; // E is zero
csei_eq[2] = mu*(sir_R0 - 1)/beta; //equilibrium value of I
}
else{
error("The equilibrium value R0 is less than 1, R0 = beta/(gamma+mu)");
}
}
else{// for SEIR model,
csei_eq[0] = (gamma+mu)*(sigma+mu)/(beta * sigma);// equilibrium value of S
csei_eq[1] = mu*((1/(sigma+mu)) - ((gamma+mu)/(beta * sigma)));// equilibrium value of E
csei_eq[2] = mu*((beta*sigma - (gamma+mu)*(sigma+mu))/(beta *(gamma+mu)*(sigma+mu)));// equilibrium value of I
}
UNPROTECT(1);
return rsei_eq;
}
SEXP RgibbsOneWayAnova(SEXP yR, SEXP NR, SEXP JR, SEXP IR, SEXP rscaleR, SEXP iterationsR, SEXP progressR, SEXP pBar, SEXP rho)
{
int iterations = INTEGER_VALUE(iterationsR);
int *N = INTEGER_POINTER(NR), progress = INTEGER_VALUE(progressR);
double rscale = NUMERIC_VALUE(rscaleR);
double *y = REAL(yR);
int J = INTEGER_VALUE(JR),I = INTEGER_VALUE(IR);
int j=0,i=0,sumN=0,counter=0,npars=0;
npars = J+5;
for(j=0;j<J;j++){
sumN += N[j];
}
double yVec[sumN];
int whichJ[sumN]; //which j the element belongs to
for(j=0;j<J;j++)
{
for(i=0;i<N[j];i++){
whichJ[counter] = j;
yVec[counter]=y[j*I + i];
//Rprintf("i %d, j %d, y %f\n",i,j,yVec[counter]);
counter++;
}
}
//We're going to add another element to returnList for debugging.
SEXP chainsR,returnListR,CMDER,debug;
PROTECT(chainsR = allocMatrix(REALSXP, npars, iterations));
PROTECT(returnListR = allocVector(VECSXP,3));
PROTECT(CMDER = allocVector(REALSXP,4));
PROTECT(debug = allocVector(VECSXP,2));
gibbsOneWayAnova(yVec, N, J, sumN, whichJ, rscale, iterations, REAL(chainsR), REAL(CMDER), debug, progress, pBar, rho);
SET_VECTOR_ELT(returnListR, 0, chainsR);
SET_VECTOR_ELT(returnListR, 1, CMDER);
SET_VECTOR_ELT(returnListR, 2, debug);
UNPROTECT(4);
return(returnListR);
}
SEXP CBinIt1(MatrixType x, index_type nr, SEXP pcol, SEXP Baddr)
{
index_type i, k;
double *pB = NUMERIC_DATA(Baddr);
double min = pB[0];
double max = pB[1];
index_type nbins = (index_type) pB[2];
index_type col = (index_type) NUMERIC_VALUE(pcol) - 1;
int good;
T *pc = x[col];
SEXP Rret;
Rret = PROTECT(NEW_NUMERIC(nbins));
double *ret = NUMERIC_DATA(Rret);
for (i=0; i<nbins; i++) {
ret[i] = 0.0;
}
for (k=0; k<nr; k++) {
if ( !isna(pc[k]) ){
good = 1;
if ( (((double)pc[k])>=min) && (((double)pc[k])<=max) ) {
i = (index_type) ( nbins * (((double)pc[k])-min) / (max-min) );
if (i==(index_type)nbins) i--;
} else { good = 0; }
if (good == 1) {
ret[i]++;
}
} // End only do work in there isn't an NA value
} // End looping over all rows.
UNPROTECT(1);
return(Rret);
}
SEXP rph_gff_overlapSelect(SEXP gffP, SEXP filter_gffP,
SEXP numbaseOverlapP,
SEXP percentOverlapP,
SEXP nonOverlappingP,
SEXP overlappingFragmentsP) {
GFF_Set *gff, *filter_gff, *overlapping_gff=NULL;
int numbaseOverlap, nonOverlapping;
double percentOverlap, overlappingFragments;
gff = (GFF_Set*)EXTPTR_PTR(gffP);
gff_register_protect(gff);
filter_gff = (GFF_Set*)EXTPTR_PTR(filter_gffP);
if (percentOverlapP == R_NilValue)
percentOverlap = -1.0;
else percentOverlap = NUMERIC_VALUE(percentOverlapP);
if (nonOverlappingP == R_NilValue)
nonOverlapping = FALSE;
else nonOverlapping = LOGICAL_VALUE(nonOverlappingP);
if (numbaseOverlapP == R_NilValue)
numbaseOverlap = -1;
else numbaseOverlap = INTEGER_VALUE(numbaseOverlapP);
if (overlappingFragmentsP == R_NilValue)
overlappingFragments = FALSE;
else overlappingFragments = LOGICAL_VALUE(overlappingFragmentsP);
if (overlappingFragments) overlapping_gff = gff_new_set();
filter_gff = gff_overlap_gff(gff, filter_gff,
numbaseOverlap, percentOverlap, nonOverlapping,
overlappingFragments, overlapping_gff);
if (overlappingFragments) {
ListOfLists *rv = lol_new(2);
lol_push_gff_ptr(rv, filter_gff, "frags");
lol_push_gff_ptr(rv, overlapping_gff, "filter.frags");
return rph_listOfLists_to_SEXP(rv);
}
return rph_gff_new_extptr(filter_gff);
}
SEXP distances_sampling(SEXP dist_id_var, SEXP n_var, SEXP m_var, SEXP theta_var){
GetRNGstate();
int m = INTEGER_VALUE(m_var);
int n = INTEGER_VALUE(n_var);
int dist_id = INTEGER_VALUE(dist_id_var);
double theta = NUMERIC_VALUE(theta_var);
int **sample= new int*[m];
SEXP Rval;
Generic gen;
Exponential_model * exp_mod = gen.new_instance(dist_id, n);
exp_mod->distances_sampling(m,theta,sample);
PROTECT(Rval = allocMatrix(REALSXP, m, n));
for (int i = 0; i < m; i++)
for (int j = 0; j < n; j++)
REAL(Rval)[i + m * j] = sample[i][j];
UNPROTECT(1);
for (int i = 0 ; i < m ; i ++ ) delete [] sample[ i ];
delete [] sample;
delete exp_mod;
PutRNGstate();
return Rval;
}
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;
}
SEXP GADEM_Analysis(SEXP sequence,SEXP sizeSeq, SEXP accession, SEXP Rverbose,SEXP RnumWordGroup,SEXP RnumTop3mer,SEXP RnumTop4mer,SEXP RnumTop5mer,SEXP RnumGeneration,SEXP RpopulationSize, SEXP RpValue,SEXP ReValue,SEXP RextTrim,SEXP RminSpaceWidth,SEXP RmaxSpaceWidth,SEXP RuseChIPscore,SEXP RnumEM,SEXP RfEM, SEXP RwidthWt,SEXP RfullScan, SEXP RslideWinPWM,SEXP RstopCriterion,SEXP RnumBackgSets,SEXP RweightType,SEXP RbFileName,SEXP RListPWM,SEXP RminSites,SEXP RmaskR,SEXP Rnmotifs)
{
char *bFileName;
SEXP ResultsGadem;
SEXP RSpwm;
PROTECT(ResultsGadem=NEW_LIST(100));
int increment=0;
double testrand;
//Number of sequences
int numSeq = INTEGER_VALUE(sizeSeq);
// const
// char *Fastaheader[size];
int incr=0;
int longueur=length(sequence);
int IncrementTemp=0;
// basic settings/info
int maxSeqLen,*seqLen; // sequence info
double aveSeqLen; // sequence info
char **seq,**rseq;
int *geneID; // sequence info
char **oseq,**orseq; // copy of the original sequences
char **sseq,**rsseq; // simulated seqs.
double *bfreq1, *bfreq0=NULL; // base frequencies
double *ChIPScore; // chip score
int maskR; // mask simple repeats before running the algorithm
// pwms
double ***pwm; // initial population of PWMs from spaced dyads
int *pwmLen; // initial pwm lengths
double **opwm2; // EM-derived PWM
double ***opwm; // observed PWMs from identified sites
double ***epwm; // em-optimized PWMs
double **logepwm; // log(em-optimized PWM)
int *pwmnewLen; // final motif length after extending to both ends
// llr score distr.
Pgfs *llrDist; // llr distribution from pgf method
int llrDim; // llr distribution dimension
int **ipwm; // integer pwm for computing llr score distribution
// EM, motif, sites
double pvalueCutoff; // user input, used to determine score cutoff based on ipwm
int *scoreCutoff; // pwm score cutoff for the corresponding p-value cutoff
double logev; // log of E-value of a motif;
int useChIPscore; // indicator for using ChIP-seq score for seq. selection for EM
int numEM; // number of EM steps
double E_valueCutoff; // log E-value cutoff
//int nsitesEM; // number of binding sites in sequences subjected to EM
int minsitesEM; // minimal number of sites in a motif in EM sequences
int *nsites; // number of binding sites in full data
int minsites; // minimal number of sites in a motif in full data
Sites **site; // binding sites in all sequences
int motifCn; // number of motifs sought and found
int extTrim;
int noMotifFound; // none of the dyads in the population resulted in a motif
char **pwmConsensus; // consensus sequences of motifs
double pwmDistCutoff; // test statistic for motif pwm similarity
char *uniqMotif; // motifs in a population unique or not
int numUniq; // number of unique motifs in a population
int slideWinPWM; // sliding window for comparing pwm similarity
int widthWt; // window width in which nucleotides are given large weights for PWM optimization
int fullScan; // scan scan on the original sequences or masked sequences
// background
int numBackgSets;
// weights
double **posWeight; // spatial weights
int weightType; // four weight types 0, 1, 2, 3, or 4
// words for spaced dyad
Words *word; // top-ranked k-mers as the words for spaced dyads
int numTop3mer,numTop4mer,numTop5mer; // No. of top-ranked k-mers as words for dyads
int maxWordSize; // max of the above three
int numWordGroup; // number of non-zero k-mer groups
int minSpaceWidth,maxSpaceWidth; // min and max width of spacer of the spaced dyads
Chrs **dyad; // initial population of "chromosomes"
char **sdyad; // char of spaced dyads
// GA
int populationSize,numGeneration; // GA parameters
double maxpMutationRate;
Fitness *fitness; // "chromosome" fitness
Wheel *wheel; // roulette-wheel selection
// to speed up only select a subset of sequences for EM algorithm
double fEM; // percentage of sequences used in EM algorithm
int numSeqEM; // number of sequences subject to EM
char *Iseq; // Indicator if a sequence is used in EM or not
int *emSeqLen; // length of sequences used in EM
double *maxpFactor;
int numCycle; // number of GADEM cycles
int generationNoMotif; // maximal number of GA generations in a GADEM cycle resulted in no motifs
// mis.
//seed_t seed; // random seed
int motifCn2,id,numCycleNoMotif,verbose,minminSites,nmotifs;
int startPWMfound,stopCriterion;
char *mFileName,*oFileName,*pwmFileName,*tempRbFileName;
time_t start;
int cn[4],bcn[4],*seqCn,*bseqCn,avebnsites,avebnsiteSeq,totalSitesInput;
int i;
int ii=0;
int jjj=0;
/*************/
FILE * output = fopen("output.txt", "w");
/*************/
GetRNGstate();
mFileName=alloc_char(500); mFileName[0]='\0';
oFileName=alloc_char(500); oFileName[0]='\0';
pwmFileName=alloc_char(500); pwmFileName[0]='\0';
bFileName=alloc_char(500); bFileName[0]='\0';
//tempRbFileName=alloc_char(500); tempRbFileName[0]='\0';
seq=NULL; aveSeqLen=0; maxSeqLen=0;
//minsites=-1;
startPWMfound=0;
maxSeqLen=0;
for(incr=1;incr<longueur;incr=incr+2)
{
if (length(STRING_ELT(sequence,(incr)))>maxSeqLen) maxSeqLen=length(STRING_ELT(sequence,(incr)));
}
// fprintf(output,"maxLength=%d",maxSeqLen);
// exit(0);
seq=alloc_char_char(numSeq,maxSeqLen+1);
for(incr=1;incr<longueur;incr=incr+2)
{
for (int j=0; j<length(STRING_ELT(sequence,(incr))); j++)
{
seq[IncrementTemp][j]=CHAR(STRING_ELT(sequence,(incr)))[j];
}
IncrementTemp++;
}
verbose=LOGICAL_VALUE(Rverbose);
numWordGroup=INTEGER_VALUE(RnumWordGroup);
minsites=INTEGER_VALUE(RminSites);
numTop3mer=INTEGER_VALUE(RnumTop3mer);
numTop4mer=INTEGER_VALUE(RnumTop4mer);
numTop5mer=INTEGER_VALUE(RnumTop5mer);
numGeneration=INTEGER_VALUE(RnumGeneration);
populationSize=INTEGER_VALUE(RpopulationSize);
pvalueCutoff=NUMERIC_VALUE(RpValue);
E_valueCutoff=NUMERIC_VALUE(ReValue);
extTrim=INTEGER_VALUE(RextTrim);
minSpaceWidth=INTEGER_VALUE(RminSpaceWidth);
maxSpaceWidth=INTEGER_VALUE(RmaxSpaceWidth);
useChIPscore=NUMERIC_VALUE(RuseChIPscore);
numEM=INTEGER_VALUE(RnumEM);
fEM=NUMERIC_VALUE(RfEM);
widthWt=INTEGER_VALUE(RwidthWt);
fullScan=INTEGER_VALUE(RfullScan);
slideWinPWM=INTEGER_VALUE(RslideWinPWM);
numUniq=populationSize;
stopCriterion=INTEGER_VALUE(RstopCriterion);
numBackgSets=INTEGER_VALUE(RnumBackgSets);
weightType=NUMERIC_VALUE(RweightType);
//const char *tempRbFileName[1];
tempRbFileName = convertRString2Char(RbFileName);
//tempRbFileName[0]=CHAR(STRING_ELT(RbFileName,0));
nmotifs = INTEGER_VALUE(Rnmotifs);
maskR = INTEGER_VALUE(RmaskR);
if(numSeq>MAX_NUM_SEQ)
{
error("Error: maximal number of seqences reached!\nPlease reset MAX_NUM_SEQ in gadem.h and rebuild (see installation)\n");
}
strcpy(bFileName,tempRbFileName);
ChIPScore=alloc_double(MAX_NUM_SEQ);
seqLen=alloc_int(MAX_NUM_SEQ);
geneID=alloc_int(MAX_NUM_SEQ);
// seq=sequences;
// numSeq=size;
int len;
for (i=0; i<numSeq; i++)
{
len=strlen(seq[i]);
seqLen[i]=len;
geneID[i]=INTEGER(accession)[i];
}
aveSeqLen=0;
for (i=0; i<numSeq; i++) aveSeqLen +=seqLen[i]; aveSeqLen /=(double)numSeq;
for (i=0; i<numSeq; i++) {
if (seqLen[i]>maxSeqLen) maxSeqLen=seqLen[i];
}
rseq=alloc_char_char(numSeq,maxSeqLen+1);
oseq=alloc_char_char(numSeq,maxSeqLen+1);
orseq=alloc_char_char(numSeq,maxSeqLen+1);
for (i=0; i<numSeq; i++)
{
if(seqLen[i]>maxSeqLen) maxSeqLen=seqLen[i];
}
reverse_seq(seq,rseq,numSeq,seqLen);
// make a copy of the original sequences both strands
for (i=0; i<numSeq; i++)
{
for (int j=0; j<seqLen[i]; j++)
{
oseq[i][j]=seq[i][j];
orseq[i][j]=rseq[i][j];
}
oseq[i][seqLen[i]]='\0'; orseq[i][seqLen[i]]='\0';
}
if (strcmp(bFileName,"NULL")!= 0)
{
bfreq0=alloc_double(5);
read_background(bFileName,bfreq0);
}
if (GET_LENGTH(RListPWM)!= 0)
{
startPWMfound=1;
}
else { }
// check for input parameters
if(numGeneration<1)
{
error("number of generaton < 1.\n");
}
if(populationSize<1)
{
error("population size < 1.\n");
}
if (minSpaceWidth<0)
{
error("minimal number of unspecified bases in spaced dyads <0.\n");
}
if (maxSpaceWidth<0)
{
error("maximal number of unspecified bases in spaced dyads <0.\n");
}
if (minSpaceWidth>maxSpaceWidth)
{
error("mingap setting must <= to maxgap setting.\n\n");
}
if (maxSpaceWidth+12>MAX_PWM_LENGTH)
{
error("maxgap setting plus word lengths exceed <MAX_PWM_LENGTH>.\n");
}
if (numEM<0)
{
error("number of EM steps is zero.\n");
}
if (numEM==0)
{
error("number of EM steps = 0, no EM optimization is carried out.\n");
}
if (fullScan!=0 && fullScan!=1)
fullScan=0;
maxWordSize=0;
if (numTop3mer>maxWordSize) maxWordSize=numTop3mer;
if (numTop4mer>maxWordSize) maxWordSize=numTop4mer;
if (numTop5mer>maxWordSize) maxWordSize=numTop5mer;
// any one, two or three: tetramer, pentamer, hexamer
if (numTop3mer==0 && numTop4mer==0 && numTop5mer==0)
{
error("maxw3, maxw4, and maxw5 all zero - no words for spaced dyads.\n");
}
// if (startPWMfound && fEM!=0.5 && fEM!=1.0 & verbose)
// {
// warning("fEM argument is ignored in a seeded analysis\n");
// }
if (startPWMfound)
{
// if(verbose)
// {
// if (populationSize!=10 && populationSize!=100) warning("pop argument is ignored in a seeded analysis, -pop is set to 10.\n");
// if (numGeneration!=1 && numGeneration!=5) warning("gen argument is ignored in a seeded analysis, -gen is set to 1.\n");
// }
fEM=1.0;
populationSize=FIXED_POPULATION; numGeneration=1;
}
// number of sequences for EM
if (fEM>1.0 || fEM<=0.0)
{
error("The fraction of sequences subject to EM is %3.2f.\n",fEM);
}
numSeqEM=(int)(fEM*numSeq);
// memory callocations
Iseq =alloc_char(numSeq+1);
opwm2 =alloc_double_double(MAX_PWM_LENGTH,4);
ipwm =alloc_int_int(MAX_PWM_LENGTH,4);
logepwm=alloc_double_double(MAX_PWM_LENGTH,4);
emSeqLen=alloc_int(numSeqEM);
scoreCutoff=alloc_int(1000);
// scoreCutoff=alloc_int(populationSize);
llrDist=alloc_distr(MAX_DIMENSION);
posWeight=alloc_double_double(numSeq,maxSeqLen);
sseq=alloc_char_char(MAX_NUM_SEQ,maxSeqLen+1);
rsseq=alloc_char_char(MAX_NUM_SEQ,maxSeqLen+1);
bfreq1=base_frequency(numSeq,seq,seqLen);
if (strcmp(bFileName,"NULL") == 0)
{
bfreq0=alloc_double(5);
for (i=0; i<4; i++)
{
bfreq0[i]=bfreq1[i];
}
}
// if minN not specified, set the defaults accordingly
if (minsites==-1)
{
minsites =max(2,(int)(numSeq/20));
}
minsitesEM=(int)(fEM*minsites);
maxpMutationRate=MAXP_MUTATION_RATE;
// determine the distribution and critical cut point
pwmDistCutoff=vector_similarity();
/*---------- select a subset of sequences for EM only --------------*/
if (useChIPscore==1)
{
select_high_scoring_seq_for_EM (ChIPScore,numSeq,numSeqEM,Iseq,fEM);
}
else
{
sample_without_replacement(Iseq,numSeqEM,numSeq);
}
/*-------------------- end of selection --------------------------*/
if (maskR==1) mask_repetitive(geneID,seq,numSeq,seqLen,mFileName);
if (widthWt<20)
{
warning("The window width of sequence centered on the nucleotides having large weights in EM for PWM optimization is small\n Motif longer than %d will not be discovered\n",widthWt);
}
time(&start);
// if (weightType==1 || weightType==3)
//ffprintf(output,fp,"window width of sequence centered on the nucleotides having large weights for PWM optimization: %d\n",widthWt);
//ffprintf(output,fp,"pwm score p-value cutoff for declaring binding site:\t%e\n",pvalueCutoff);
if(verbose)
{
ffprintf(output,output,"==============================================================================================\n");
ffprintf(output,output,"input sequence file: %s\n",mFileName);
fprintf(output,"number of sequences and average length:\t\t\t\t%d %5.1f\n",numSeq,aveSeqLen);
fprintf(output,"Use pgf method to approximate llr null distribution\n");
fprintf(output,"parameters estimated from sequences in: %s\n\n",mFileName);
if (weightType!=0)
fprintf(output,"non-uniform weight applies to each sequence - type:\t\t%d\n",weightType);
fprintf(output,"number of GA generations & population size:\t\t\t%d %d\n\n",numGeneration,populationSize);
fprintf(output,"PWM score p-value cutoff for binding site declaration:\t\t%e\n",pvalueCutoff);
fprintf(output,"ln(E-value) cutoff for motif declaration:\t\t\t%f\n\n",E_valueCutoff);
// fprintf(output,"number (percentage) of sequences selected for EM:\t\t%d(%4.1f\%)\n",numSeqEM,100.0*(double)numSeqEM/(double)numSeq);
fprintf(output,"number of EM steps:\t\t\t\t\t\t%d\n",numEM);
fprintf(output,"minimal no. sites considered for a motif:\t\t\t%d\n\n",minsites);
fprintf(output,"[a,c,g,t] frequencies in input data:\t\t\t\t%f %f %f %f\n",bfreq1[0],bfreq1[1],bfreq1[2],bfreq1[3]);
fprintf(output,"==============================================================================================\n");
}
// if (pgf)
// {
// if (userMarkovOrder!=0 & verbose)
// {
// warning("The user-specified background Markov order (%d) is ignored when -pgf is set to 1\n",userMarkovOrder);
// }
// if (bFileName[0]!='\0' & verbose)
// {
// warning("The user-specified background models: %s are not used when -pgf is set to 1\n",bFileName);
// }
// }
// if (startPWMfound && fEM!=1.0 & verbose)
// {
// warning("fEM argument is ignored in a seeded analysis\n");
// }
// determine seq length by counting only [a,c,g,t], seqLen is used in E-value calculation
// determine the distribution and critical cut point
pwmDistCutoff=vector_similarity();
if (weightType==0) assign_weight_uniform(seqLen,numSeq,posWeight);
else if (weightType==1) assign_weight_triangular(seqLen,numSeq,posWeight);
else if (weightType==2) assign_weight_normal(seqLen,numSeq,posWeight);
else
{
error("Motif prior probability type not found - please choose: 0, 1, or 2\n");
// fprintf(output,"Consider: -posWt 1 for strong central enrichment as in ChIP-seq\n");
// fprintf(output," -posWt 0 for others\n\n");
// exit(0);
}
/* if (startPWMfound) minminSites=minsites;
else minminSites=(int)(0.40*minsitesEM);*/
motifCn=0; noMotifFound=0; numCycle=0; numCycleNoMotif=0;
int compt=0;
int lengthList=GET_LENGTH(RListPWM);
/****************************************/
broadcastOnce(maxSeqLen, numEM, startPWMfound, minminSites, maxpFactor, numSeq, numSeqEM, Iseq, bfreq0, posWeight, weightType, pvalueCutoff, emSeqLen, populationSize);
/****************************************/
do
{
if(!startPWMfound)
{
if(verbose)
{
fprintf(output,"*** Running an unseeded analysis ***\n");
// fprintf(output,"\n|------------------------------------------------------------------|\n");
// fprintf(output,"| |\n");
// fprintf(output,"| *** Running an unseeded analysis *** |\n");
// fprintf(output,"| |\n");
// fprintf(output,"|------------------------------------------------------------------|\n\n");
}
populationSize=INTEGER_VALUE(RpopulationSize);
numGeneration=INTEGER_VALUE(RnumGeneration);
dyad =alloc_chrs(populationSize,4);
wheel =alloc_wheel(populationSize);
fitness=alloc_fitness(populationSize);
maxpFactor=alloc_double(populationSize);
uniqMotif=alloc_char(populationSize+1);
opwm =alloc_double_double_double(populationSize,MAX_PWM_LENGTH,4);
epwm=alloc_double_double_double(populationSize,MAX_PWM_LENGTH,4);
pwmConsensus=alloc_char_char(populationSize,MAX_PWM_LENGTH+1);
pwm =alloc_double_double_double(populationSize,MAX_PWM_LENGTH,4);
pwmLen=alloc_int(populationSize);
sdyad =alloc_char_char(populationSize,MAX_PWM_LENGTH+1);
word =alloc_word(numWordGroup,maxWordSize);
minminSites=(int)(0.40*minsitesEM);
// identify top-ranked k-mers (k=3,4,5) for spaced dyads
if(verbose)
fprintf(output,"GADEM cycle %2d: enumerate and count k-mers... ",numCycle+1);
numWordGroup=word_for_dyad(word,seq,rseq,numSeq,seqLen,bfreq1,&numTop3mer,&numTop4mer,&numTop5mer);
if(verbose)
fprintf(output,"Done.\n");
// generating a "population" of spaced dyads
if(verbose)
fprintf(output,"Initializing GA... ");
initialisation(dyad,populationSize,numWordGroup,word,minSpaceWidth,maxSpaceWidth,maxpFactor);
if(verbose)
fprintf(output,"Done.\n");
}
else
{
if(verbose)
{
fprintf(output,"*** Running an seeded analysis ***\n");
// fprintf(output,"\n|------------------------------------------------------------------|\n");
// fprintf(output,"| |\n");
// fprintf(output,"| *** Running a seeded analysis *** |\n");
// fprintf(output,"| |\n");
// fprintf(output,"|------------------------------------------------------------------|\n\n");
}
populationSize=FIXED_POPULATION;
dyad =alloc_chrs(populationSize,4);
pwm=alloc_double_double_double(populationSize,MAX_PWM_LENGTH,4);
pwmLen=alloc_int(populationSize);
maxpFactor=alloc_double(populationSize);
uniqMotif=alloc_char(populationSize+1);
opwm =alloc_double_double_double(populationSize,MAX_PWM_LENGTH,4);
epwm=alloc_double_double_double(populationSize,MAX_PWM_LENGTH,4);
pwmConsensus=alloc_char_char(populationSize,MAX_PWM_LENGTH+1);
sdyad =alloc_char_char(populationSize,MAX_PWM_LENGTH+1);
word =alloc_word(numWordGroup,maxWordSize);
wheel =alloc_wheel(populationSize);
fitness=alloc_fitness(populationSize);
minminSites=minsites;
int lengthMatrix;
lengthMatrix=GET_LENGTH(VECTOR_ELT(RListPWM,compt));
RSpwm=allocMatrix(REALSXP,4,(lengthMatrix/4));
RSpwm=VECTOR_ELT(RListPWM,compt);
pwmLen[0]=read_pwm0(RSpwm,pwm[0],lengthMatrix);
for(i=1; i<populationSize; i++)
{
for (int j=0; j<pwmLen[0]; j++)
{
for (int k=0; k<4; k++)
{
pwm[i][j][k]=pwm[0][j][k];
}
}
pwmLen[i]=pwmLen[0];
}
for (i=0; i<populationSize; i++)
{
maxpFactor[i]=FIXED_MAXPF*(i+1);
standardize_pwm(pwm[i],pwmLen[i]);
consensus_pwm(pwm[i],pwmLen[i],pwmConsensus[i]);
strcpy(sdyad[i],pwmConsensus[i]);
}
}
generationNoMotif=0;
for (jjj=0; jjj<numGeneration; jjj++)
{
// convert spaced dyads to letter probability matrix
if (!startPWMfound)
{
dyad_to_pwm(word,populationSize,dyad,pwm,pwmLen);
}
/*
DO_APPLY(populationCalculation(maxSeqLen, numEM, fitness+ii,
startPWMfound, minminSites, maxpFactor[ii],
numSeq, numSeqEM, seq, rseq, seqLen, Iseq,
bfreq0, posWeight, weightType,
pvalueCutoff, emSeqLen,
pwm[ii], pwmLen[ii], epwm[ii], opwm[ii],
pwmConsensus[ii], scoreCutoff+ii, sdyad[ii], ii),
populationSize, ii);
*/
/* Create the structure to send to all the other slaves */
broadcastEveryCycle(Iseq, pwm, pwmLen, pwmConsensus, scoreCutoff, sdyad, populationSize);
populationCalculation(maxSeqLen, numEM, fitness+ii,
startPWMfound, minminSites, maxpFactor[ii],
numSeq, numSeqEM, seq, rseq, seqLen, Iseq,
bfreq0, posWeight, weightType,
pvalueCutoff, emSeqLen,
pwm[ii], pwmLen[ii], epwm[ii], opwm[ii],
pwmConsensus[ii], scoreCutoff+ii, sdyad[ii], ii);
/* Receive the analyzed data from all the other slaves and compile them */
//getPopCalcResults(...);
// for (i=0; i<5; i++)
// {
// fprintf(output,"fitness.value=%lf\n",fitness[i].value);
// fprintf(output,"fitness.index=%d\n",fitness[i].index);
// fprintf(output,"maxpfactor=%lf\n",maxpFactor[i]);
// fprintf(output,"scoreCutoff=%d\n",scoreCutoff[i]);
// fprintf(output," spacedDyad: %s\n",sdyad[i]);
//
// for (l=0; l<pwmLen[i]; l++)
// {
// for (m=0; m<4; m++)
// {
// fprintf(output,"opwm[%d][%d][%d]=%lf ",i,l,m,opwm[i][l][m]);
// fprintf(output,"epwm[%d][%d][%d]=%lf ",i,l,m,epwm[i][l][m]);
// fprintf(output,"pwm[%d][%d][%d]=%lf ",i,l,m,pwm[i][l][m]);
// }
// fprintf(output,"\n");
// }
// fprintf(output,"\n");
// }
//
// testrand=runif(0,1);
// fprintf(output,"testrand1=%lf\n",testrand);
if (populationSize>1)
{
sort_fitness(fitness,populationSize);
}
// for (i=0; i<5; i++)
// {
// fprintf(output,"fitness.value=%lf\n",fitness[i].value);
// fprintf(output,"fitness.index=%d\n",fitness[i].index);
// }
numUniq=check_pwm_uniqueness_dist(opwm, pwmLen,
populationSize, fitness,
pwmDistCutoff, E_valueCutoff,
uniqMotif, slideWinPWM);
// for (i=0; i<5; i++)
// {
// fprintf(output,"fitness.value=%lf\n",fitness[i].value);
// fprintf(output,"fitness.index=%d\n",fitness[i].index);
// fprintf(output,"maxpfactor=%lf\n",maxpFactor[i]);
// fprintf(output,"scoreCutoff=%d\n",scoreCutoff[i]);
// fprintf(output," spacedDyad: %s\n",sdyad[i]);
//
// for (l=0; l<pwmLen[i]; l++)
// {
// for (m=0; m<4; m++)
// {
// fprintf(output,"opwm[%d][%d][%d]=%lf",i,l,m,opwm[i][l][m]);
// }
// fprintf(output,"\n");
// }
// fprintf(output,"\n");
// }
if(verbose)
{
fprintf(output,"GADEM cycle[%3d] generation[%3d] number of unique motif: %d\n",numCycle+1,jjj+1,numUniq);
for (i=0; i<populationSize; i++)
{
if (uniqMotif[i]=='1')
{
fprintf(output," spacedDyad: %s ",sdyad[fitness[i].index]);
for (int j=strlen(sdyad[fitness[i].index]); j<maxSpaceWidth+10; j++) fprintf(output," ");
fprintf(output,"motifConsensus: %s ",pwmConsensus[fitness[i].index]);
for (int j=strlen(sdyad[fitness[i].index]); j<maxSpaceWidth+10; j++) fprintf(output," ");
fprintf(output," %3.2f fitness: %7.2f\n",maxpFactor[fitness[i].index],fitness[i].value);
}
}
fprintf(output,"\n");
}
if (jjj<numGeneration-1)
{
// fitness based selection with replacement
roulett_wheel_fitness(fitness,populationSize,wheel);
// mutation and crossover operations
if (populationSize>1)
{
testrand=runif(0,1);
if (testrand>=0.5)
{
mutation(dyad,numWordGroup,word,minSpaceWidth,maxSpaceWidth,wheel,populationSize,fitness,uniqMotif,
maxpFactor,maxpMutationRate);
}
else
{
crossover(dyad,numWordGroup,word,minSpaceWidth,maxSpaceWidth,wheel,populationSize,fitness,uniqMotif, maxpFactor,maxpMutationRate);
}
}
else
{
mutation(dyad,numWordGroup,word,minSpaceWidth,maxSpaceWidth,wheel,populationSize,fitness,uniqMotif, maxpFactor,maxpMutationRate);
}
}
}
if((numCycle+1)< lengthList)
{
compt++;
}
else
{
startPWMfound=0;
}
numCycle++;
site=alloc_site_site(numUniq+1,MAX_SITES);
nsites=alloc_int(numUniq+1);
pwmnewLen=alloc_int(numUniq+1); // after base extension and trimming
seqCn=alloc_int(MAX_NUM_SEQ);
bseqCn=alloc_int(MAX_NUM_SEQ);
// final step user-specified background model is used
motifCn2=0; // motifCn per GADEM cycle
for (ii=0; ii<populationSize; ii++)
{
id=fitness[ii].index;
if(uniqMotif[ii]=='0')
{
continue;
}
// approximate the exact llr distribution using Staden's method
// if(verbose)
// {
// fprintf(output,"Approximate the exact pwm llr score distribution using the pgf method.\n");
// }
log_ratio_to_int(epwm[id],ipwm,pwmLen[id],bfreq0);
// compute score distribution of the (int)PWM using Staden's method
llrDim=pwm_score_dist(ipwm,pwmLen[id],llrDist,bfreq0);
//fprintf(output,"Avant ScoreCutoff %d \n",scoreCutoff[id]);
scoreCutoff[id]=determine_cutoff(llrDist,llrDim,pvalueCutoff);
//fprintf(output,"Apres ScoreCutoff %d \n",scoreCutoff[id]);
if(fullScan)
{
nsites[motifCn2]=scan_llr_pgf(llrDist,llrDim,site[motifCn2],numSeq,oseq,orseq,seqLen,ipwm,pwmLen[id],scoreCutoff[id],bfreq0);
}
else
{
nsites[motifCn2]=scan_llr_pgf(llrDist,llrDim,site[motifCn2],numSeq,seq,rseq,seqLen,ipwm,pwmLen[id],scoreCutoff[id],bfreq0);
}
if (nsites[motifCn2]>=max(2,minsites))
{
for (int j=0; j<numSeq; j++) seqCn[j]=0;
for (int j=0; j<nsites[motifCn2]; j++) seqCn[site[motifCn2][j].seq]++;
for (int j=0; j<4; j++) cn[j]=0;
for (int j=0; j<numSeq; j++)
{
if (seqCn[j]==0) cn[0]++;
if (seqCn[j]==1) cn[1]++;
if (seqCn[j]==2) cn[2]++;
if (seqCn[j]>2) cn[3]++;
}
totalSitesInput=nsites[motifCn2];
if (extTrim)
{
if (fullScan)
{
extend_alignment(site[motifCn2],numSeq,oseq,orseq,seqLen,nsites[motifCn2],pwmLen[id],&(pwmnewLen[motifCn2]));
}
else
{
extend_alignment(site[motifCn2],numSeq,seq,rseq,seqLen,nsites[motifCn2],pwmLen[id],&(pwmnewLen[motifCn2]));
}
}
else
{
pwmnewLen[motifCn2]=pwmLen[id];
}
if (fullScan)
{
align_sites_count(site[motifCn2],oseq,orseq,nsites[motifCn2],pwmnewLen[motifCn2],opwm2);
}
else
{
align_sites_count(site[motifCn2],seq,rseq,nsites[motifCn2],pwmnewLen[motifCn2],opwm2);
}
standardize_pwm(opwm2,pwmnewLen[motifCn2]);
logev=E_value(opwm2,nsites[motifCn2],bfreq0,pwmnewLen[motifCn2],numSeq,seqLen);
if (logev<=E_valueCutoff)
{
consensus_pwm(opwm2,pwmnewLen[motifCn2],pwmConsensus[id]);
if (fullScan)
{
SET_VECTOR_ELT(ResultsGadem,increment,print_result_R(site[motifCn2],nsites[motifCn2],numSeq,oseq,orseq,seqLen,logev,opwm2,pwmnewLen[motifCn2],motifCn+1,sdyad[id],pwmConsensus[id],numCycle,pvalueCutoff,maxpFactor[id],geneID));
increment++;
print_motif(site[motifCn2],nsites[motifCn2],oseq,orseq,seqLen,pwmnewLen[motifCn2],motifCn+1,opwm2);
}
else
{
SET_VECTOR_ELT(ResultsGadem,increment,print_result_R(site[motifCn2],nsites[motifCn2],numSeq,seq,rseq,seqLen,logev,opwm2,pwmnewLen[motifCn2],
motifCn+1,sdyad[id],pwmConsensus[id],numCycle,pvalueCutoff,maxpFactor[id],geneID));
increment++;
print_motif(site[motifCn2],nsites[motifCn2],seq,rseq,seqLen,pwmnewLen[motifCn2],motifCn+1,opwm2);
}
mask_sites(nsites[motifCn2],seq,rseq,seqLen,site[motifCn2],pwmnewLen[motifCn2]);
/* ----------------------compute the average number of sites in background sequences ----------------------*/
avebnsites=0; avebnsiteSeq=0;
for (i=0; i<numBackgSets; i++)
{
simulate_background_seq(bfreq0,numSeq,seqLen,sseq);
reverse_seq(sseq,rsseq,numSeq,seqLen);
nsites[motifCn2]=scan_llr_pgf(llrDist,llrDim,site[motifCn2],numSeq,sseq,rsseq,seqLen,ipwm,pwmLen[id],scoreCutoff[id],bfreq0);
for (int j=0; j<numSeq; j++) bseqCn[j]=0;
for (int j=0; j<nsites[motifCn2]; j++) bseqCn[site[motifCn2][j].seq]++;
for (int j=0; j<4; j++) bcn[j]=0;
for (int j=0; j<numSeq; j++)
{
if (bseqCn[j]==0) bcn[0]++;
if (bseqCn[j]==1) bcn[1]++;
if (bseqCn[j]==2) bcn[2]++;
if (bseqCn[j]>2) bcn[3]++;
}
//ffprintf(output,fq,"background set[%2d] Seqs with 0,1,2,>2 sites: %d %d %d %d\n",i+1,bcn[0],bcn[1],bcn[2],bcn[3]);
avebnsites+=nsites[motifCn2]; avebnsiteSeq+=(numSeq-bcn[0]);
}
avebnsites/=numBackgSets; avebnsiteSeq/=numBackgSets;
/* -----------------end compute the average number of sites in background sequences ----------------------*/
motifCn++; motifCn2++;
//if((numCycle+1) > lengthList & fixSeeded)
// {
// numCycleNoMotif=1;
// startPWMfound=1;
// } else {
numCycleNoMotif=0;
// }
}
}
}
/* for (int i=0; i<motifCn2; i++)
{
mask_sites(nsites[i],seq,rseq,seqLen,site[i],pwmnewLen[i]);
} */
if (site[0])
{
free(site[0]);
site[0]=NULL;
}
if (site)
{
free(site);
site=NULL;
}
if (nsites)
{
free(nsites);
nsites=NULL;
}
if (pwmnewLen)
{
free(pwmnewLen);
pwmnewLen=NULL;
}
if (motifCn2==0)
numCycleNoMotif++;
if (motifCn==nmotifs)
{
fprintf(output,"Maximal number of motifs (%d) reached\n",nmotifs);
break;
}
if (numCycleNoMotif==stopCriterion)
noMotifFound=1;
}while (!noMotifFound);
// fclose(fp);
/*if (!startPWMfound) {
if (dyad[0]) { free(dyad[0]); dyad[0]=NULL; }
if (dyad) { free(dyad); dyad=NULL; }
}*/
if (seqLen)
{
free(seqLen);
seqLen=NULL;
}
if (pwm[0][0])
{
free(pwm[0][0]);
pwm[0][0]=NULL;
}
if (pwm[0])
{
free(pwm[0]);
pwm[0]=NULL;
}
if (pwm)
{
free(pwm);
pwm=NULL;
}
if (opwm2[0])
{
free(opwm2[0]);
opwm2[0]=NULL;
}
if (opwm2)
{
free(opwm2);
opwm2=NULL;
}
if (opwm[0][0])
{
free(opwm[0][0]);
opwm[0][0]=NULL;
}
if (opwm[0])
{
free(opwm[0]);
opwm[0]=NULL;
}
if (opwm)
{
free(opwm);
opwm=NULL;
}
if(ipwm[0])
{
free(ipwm[0]);
ipwm[0]=NULL;
}
if (ipwm)
{
free(ipwm);
ipwm=NULL;
}
if (pwmLen)
{
free(pwmLen);
pwmLen=NULL;
}
if (seq[0]) { free(seq[0]); seq[0]=NULL; }
if (seq) { free(seq); seq=NULL; }
// if (rseq[0]) { free(rseq[0]); rseq[0]=NULL; }
// if (rseq) { free(rseq); rseq=NULL; }
// if (oseq[0]) { free(oseq[0]); oseq[0]=NULL; }
// if (oseq) { free(oseq); oseq=NULL; }
// if (orseq[0]) { free(orseq[0]); orseq[0]=NULL; }
// if (orseq) { free(orseq); orseq=NULL; }
if (bfreq1)
{
free(bfreq1);
bfreq1=NULL;
}
if (bfreq0)
{
free(bfreq0);
bfreq0=NULL;
}
if (wheel)
{
free(wheel);
wheel=NULL;
}
if (fitness)
{
free(fitness);
fitness=NULL;
}
if (mFileName)
{
free(mFileName);
mFileName=NULL;
}
if (oFileName)
{
free(oFileName);
oFileName=NULL;
}
if (pwmFileName)
{
free(pwmFileName);
pwmFileName=NULL;
}
if (sdyad[0])
{
free(sdyad[0]);
sdyad[0]=NULL;
}
if (sdyad)
{
free(sdyad);
sdyad=NULL;
}
if (pwmConsensus[0])
{
free(pwmConsensus[0]);
pwmConsensus[0]=NULL;
}
if (pwmConsensus)
{
free(pwmConsensus);
pwmConsensus=NULL;
}
//if (!startPWMfound && word) destroy_word(word,numWordGroup);
PutRNGstate();
UNPROTECT(1);
return(ResultsGadem);
}
SEXP lsoda_oscillatore(SEXP parms, SEXP X0, SEXP times, SEXP metodo, SEXP atol, SEXP rtol, SEXP stat_thr, SEXP stat_width)
{
int i, ll, nProtected = 0;
VETTOREd *X01 = NULL, *times1 = NULL;
MATRICEd *ris1 = NULL;
LISTA *parms1 = NULL;
GString *metodo1 = NULL;
double atol1, rtol1, stat_thr1, stat_width1;
#ifdef MDEBUG
GString **nomi;
char tmp[15];
#endif
enum TIPO *tipi;
SEXP ris;
_InitDbg(false, false, false);
_Intestazione("\n*** lsoda_oscillatore ***\n");
ll = length(parms);
tipi = mia_alloc(ll, enum TIPO);
if (ll > 0 && tipi == NULL) {
Rprintf("Not enough memory (lsoda_oscillatore # %d, tipi)", __LINE__ - 2);
error("");
}
#ifdef MDEBUG
nomi = mia_alloc(ll, GString *);
if (ll > 0 && nomi == NULL) {
Rprintf("Not enough memory (lsoda_oscillatore # %d, nomi)", __LINE__ - 2);
error("");
}
#endif
X01 = inVETTORE_d(X0, &nProtected);
times1 = inVETTORE_d(times, &nProtected);
metodo1 = inSTRINGA(metodo, &nProtected, "metodo");
atol1 = NUMERIC_VALUE(atol);
rtol1 = NUMERIC_VALUE(rtol);
stat_thr1 = NUMERIC_VALUE(stat_thr);
stat_width1 = NUMERIC_VALUE(stat_width);
tipi[0] = VETTd;
tipi[1] = VETTd;
tipi[2] = VETTd;
tipi[3] = VETTd;
tipi[4] = VETTd;
for (i = 0; i < ll; i++) {
#ifdef MDEBUG
if (i < ll)
snprintf(tmp, 15, "Lista parms %d", i + 1);
else
tmp[0] = '\0';
CREAstr(nomi[i], tmp);
#endif
}
parms1 = inLISTA(parms, &nProtected, ll, tipi, nomi);
libera(tipi);
#ifdef MDEBUG
for (i = 0; i < ll; i++)
CANCELLAstr(nomi[i]);
libera(nomi);
#endif
ris1 = lsoda_oscillatore1(ris1, parms1, X01, times1, metodo1->str, atol1, rtol1, stat_thr1, stat_width1);
ris = daMATRICE_d(ris1, &nProtected);
CancellaLISTA(parms1, true);
CANCELLAv_d(X01);
CANCELLAv_d(times1);
CANCELLAstr(metodo1);
StrBilanciam();
ControllaCanc();
UNPROTECT(nProtected);
return ris;
}
SEXP DEoptimC(SEXP lower, SEXP upper, SEXP fn, SEXP control, SEXP rho, SEXP fnMap)
{
int i, j, P=0;
if (!isFunction(fn))
error("fn is not a function!");
if (!isEnvironment(rho))
error("rho is not an environment!");
/*-----Initialization of annealing parameters-------------------------*/
/* value to reach */
double VTR = NUMERIC_VALUE(getListElement(control, "VTR"));
/* chooses DE-strategy */
int i_strategy = INTEGER_VALUE(getListElement(control, "strategy"));
/* Maximum number of generations */
int i_itermax = INTEGER_VALUE(getListElement(control, "itermax"));
/* Dimension of parameter vector */
int i_D = INTEGER_VALUE(getListElement(control, "npar"));
/* Number of population members */
int i_NP = INTEGER_VALUE(getListElement(control, "NP"));
/* When to start storing populations */
int i_storepopfrom = INTEGER_VALUE(getListElement(control, "storepopfrom"))-1;
/* How often to store populations */
int i_storepopfreq = INTEGER_VALUE(getListElement(control, "storepopfreq"));
/* User-defined inital population */
int i_specinitialpop = INTEGER_VALUE(getListElement(control, "specinitialpop"));
double *initialpopv = NUMERIC_POINTER(getListElement(control, "initialpop"));
/* stepsize */
double d_weight = NUMERIC_VALUE(getListElement(control, "F"));
/* crossover probability */
double d_cross = NUMERIC_VALUE(getListElement(control, "CR"));
/* Best of parent and child */
int i_bs_flag = NUMERIC_VALUE(getListElement(control, "bs"));
/* Print progress? */
int i_trace = NUMERIC_VALUE(getListElement(control, "trace"));
/* p to define the top 100p% best solutions */
double d_pPct = NUMERIC_VALUE(getListElement(control, "p"));
/* crossover adaptation (a positive constant between 0 and 1) */
double d_c = NUMERIC_VALUE(getListElement(control, "c"));
/* relative tolerance */
double d_reltol = NUMERIC_VALUE(getListElement(control, "reltol"));
/* relative tolerance steps */
int i_steptol = NUMERIC_VALUE(getListElement(control, "steptol"));
int i_nstorepop = ceil((i_itermax - i_storepopfrom) / i_storepopfreq);
/* Use S_alloc, since it initializes with zeros FIXME: these should be SEXP */
double *gd_storepop = (double *)S_alloc(i_NP,sizeof(double) * i_D * i_nstorepop);
/* External pointers to return to R */
SEXP sexp_bestmem, sexp_bestval, sexp_nfeval, sexp_iter,
out, sexp_pop, sexp_storepop, sexp_bestmemit, sexp_bestvalit;
PROTECT(sexp_bestmem = NEW_NUMERIC(i_D)); P++;
PROTECT(sexp_pop = allocMatrix(REALSXP, i_D, i_NP)); P++;
PROTECT(sexp_bestmemit = allocMatrix(REALSXP, i_itermax, i_D)); P++;
PROTECT(sexp_bestvalit = allocVector(REALSXP, i_itermax)); P++;
double *gt_bestP = REAL(sexp_bestmem);
double *gd_pop = REAL(sexp_pop);
double *gd_bestmemit = REAL(sexp_bestmemit);
double *gd_bestvalit = REAL(sexp_bestvalit);
/* ensure lower and upper are double */
if(TYPEOF(lower) != REALSXP) {PROTECT(lower = coerceVector(lower, REALSXP)); P++;}
if(TYPEOF(upper) != REALSXP) {PROTECT(upper = coerceVector(upper, REALSXP)); P++;}
double *d_lower = REAL(lower);
double *d_upper = REAL(upper);
double gt_bestC;
int gi_iter = 0;
long l_nfeval = 0;
/*---optimization--------------------------------------*/
devol(VTR, d_weight, d_cross, i_bs_flag, d_lower, d_upper, fn, rho, i_trace,
i_strategy, i_D, i_NP, i_itermax,
initialpopv, i_storepopfrom, i_storepopfreq,
i_specinitialpop,
gt_bestP, >_bestC,
gd_pop, gd_storepop, gd_bestmemit, gd_bestvalit,
&gi_iter, d_pPct, d_c, &l_nfeval,
d_reltol, i_steptol, fnMap);
/*---end optimization----------------------------------*/
j = i_nstorepop * i_NP * i_D;
PROTECT(sexp_storepop = NEW_NUMERIC(j)); P++;
for (i = 0; i < j; i++)
NUMERIC_POINTER(sexp_storepop)[i] = gd_storepop[i];
PROTECT(sexp_nfeval = ScalarInteger(l_nfeval)); P++;
PROTECT(sexp_iter = ScalarInteger(gi_iter)); P++;
PROTECT(sexp_bestval = ScalarReal(gt_bestC)); P++;
const char *out_names[] = {"bestmem", "bestval", "nfeval",
"iter", "bestmemit", "bestvalit", "pop", "storepop", ""};
PROTECT(out = mkNamed(VECSXP, out_names)); P++;
SET_VECTOR_ELT(out, 0, sexp_bestmem);
SET_VECTOR_ELT(out, 1, sexp_bestval);
SET_VECTOR_ELT(out, 2, sexp_nfeval);
SET_VECTOR_ELT(out, 3, sexp_iter);
SET_VECTOR_ELT(out, 4, sexp_bestmemit);
SET_VECTOR_ELT(out, 5, sexp_bestvalit);
SET_VECTOR_ELT(out, 6, sexp_pop);
SET_VECTOR_ELT(out, 7, sexp_storepop);
UNPROTECT(P);
return out;
}
SEXP euler_model_simulator (SEXP func,
SEXP xstart, SEXP times, SEXP params,
SEXP deltat, SEXP method, SEXP zeronames,
SEXP tcovar, SEXP covar, SEXP args, SEXP gnsi)
{
int nprotect = 0;
pompfunmode mode = undef;
int nvars, npars, nreps, ntimes, nzeros, ncovars, covlen;
int nstep = 0;
double dt, dtt;
SEXP X;
SEXP ans, nm, fn, fcall = R_NilValue, rho = R_NilValue;
SEXP Snames, Pnames, Cnames;
SEXP cvec, tvec = R_NilValue;
SEXP xvec = R_NilValue, pvec = R_NilValue, dtvec = R_NilValue;
int *pidx = 0, *sidx = 0, *cidx = 0, *zidx = 0;
pomp_onestep_sim *ff = NULL;
int meth = INTEGER_VALUE(method);
// meth: 0 = Euler, 1 = one-step, 2 = fixed step
dtt = NUMERIC_VALUE(deltat);
if (dtt <= 0)
errorcall(R_NilValue,"'delta.t' should be a positive number");
{
int *dim;
dim = INTEGER(GET_DIM(xstart)); nvars = dim[0]; nreps = dim[1];
dim = INTEGER(GET_DIM(params)); npars = dim[0];
dim = INTEGER(GET_DIM(covar)); covlen = dim[0]; ncovars = dim[1];
ntimes = LENGTH(times);
}
PROTECT(Snames = GET_ROWNAMES(GET_DIMNAMES(xstart))); nprotect++;
PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++;
PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(covar))); nprotect++;
// set up the covariate table
struct lookup_table covariate_table = {covlen, ncovars, 0, REAL(tcovar), REAL(covar)};
// vector for interpolated covariates
PROTECT(cvec = NEW_NUMERIC(ncovars)); nprotect++;
SET_NAMES(cvec,Cnames);
// indices of accumulator variables
nzeros = LENGTH(zeronames);
zidx = INTEGER(PROTECT(matchnames(Snames,zeronames,"state variables"))); nprotect++;
// extract user function
PROTECT(fn = pomp_fun_handler(func,gnsi,&mode)); nprotect++;
// set up
switch (mode) {
case Rfun: // R function
PROTECT(dtvec = NEW_NUMERIC(1)); nprotect++;
PROTECT(tvec = NEW_NUMERIC(1)); nprotect++;
PROTECT(xvec = NEW_NUMERIC(nvars)); nprotect++;
PROTECT(pvec = NEW_NUMERIC(npars)); nprotect++;
SET_NAMES(xvec,Snames);
SET_NAMES(pvec,Pnames);
// set up the function call
PROTECT(fcall = LCONS(cvec,args)); nprotect++;
SET_TAG(fcall,install("covars"));
PROTECT(fcall = LCONS(dtvec,fcall)); nprotect++;
SET_TAG(fcall,install("delta.t"));
PROTECT(fcall = LCONS(pvec,fcall)); nprotect++;
SET_TAG(fcall,install("params"));
PROTECT(fcall = LCONS(tvec,fcall)); nprotect++;
SET_TAG(fcall,install("t"));
PROTECT(fcall = LCONS(xvec,fcall)); nprotect++;
SET_TAG(fcall,install("x"));
PROTECT(fcall = LCONS(fn,fcall)); nprotect++;
// get function's environment
PROTECT(rho = (CLOENV(fn))); nprotect++;
break;
case native: // native code
// construct state, parameter, covariate indices
sidx = INTEGER(PROTECT(matchnames(Snames,GET_SLOT(func,install("statenames")),"state variables"))); nprotect++;
pidx = INTEGER(PROTECT(matchnames(Pnames,GET_SLOT(func,install("paramnames")),"parameters"))); nprotect++;
cidx = INTEGER(PROTECT(matchnames(Cnames,GET_SLOT(func,install("covarnames")),"covariates"))); nprotect++;
*((void **) (&ff)) = R_ExternalPtrAddr(fn);
break;
default:
errorcall(R_NilValue,"unrecognized 'mode' %d",mode); // # nocov
break;
}
// create array to hold results
{
int dim[3] = {nvars, nreps, ntimes};
PROTECT(X = makearray(3,dim)); nprotect++;
setrownames(X,Snames,3);
}
// copy the start values into the result array
memcpy(REAL(X),REAL(xstart),nvars*nreps*sizeof(double));
if (mode==1) {
set_pomp_userdata(args);
GetRNGstate();
}
// now do computations
{
int first = 1;
int use_names = 0;
int *posn = 0;
double *time = REAL(times);
double *xs = REAL(X);
double *xt = REAL(X)+nvars*nreps;
double *cp = REAL(cvec);
double *ps = REAL(params);
double t = time[0];
double *pm, *xm;
int i, j, k, step;
for (step = 1; step < ntimes; step++, xs = xt, xt += nvars*nreps) {
R_CheckUserInterrupt();
if (t > time[step]) {
errorcall(R_NilValue,"'times' is not an increasing sequence");
}
memcpy(xt,xs,nreps*nvars*sizeof(double));
// set accumulator variables to zero
for (j = 0; j < nreps; j++)
for (i = 0; i < nzeros; i++)
xt[zidx[i]+nvars*j] = 0.0;
switch (meth) {
case 0: // Euler method
dt = dtt;
nstep = num_euler_steps(t,time[step],&dt);
break;
case 1: // one step
dt = time[step]-t;
nstep = (dt > 0) ? 1 : 0;
break;
case 2: // fixed step
dt = dtt;
nstep = num_map_steps(t,time[step],dt);
break;
default:
errorcall(R_NilValue,"unrecognized 'method'"); // # nocov
break;
}
for (k = 0; k < nstep; k++) { // loop over Euler steps
// interpolate the covar functions for the covariates
table_lookup(&covariate_table,t,cp);
for (j = 0, pm = ps, xm = xt; j < nreps; j++, pm += npars, xm += nvars) { // loop over replicates
switch (mode) {
case Rfun: // R function
{
double *xp = REAL(xvec);
double *pp = REAL(pvec);
double *tp = REAL(tvec);
double *dtp = REAL(dtvec);
double *ap;
*tp = t;
*dtp = dt;
memcpy(xp,xm,nvars*sizeof(double));
memcpy(pp,pm,npars*sizeof(double));
if (first) {
PROTECT(ans = eval(fcall,rho)); nprotect++; // evaluate the call
if (LENGTH(ans) != nvars) {
errorcall(R_NilValue,"user 'step.fun' returns a vector of %d state variables but %d are expected: compare initial conditions?",
LENGTH(ans),nvars);
}
PROTECT(nm = GET_NAMES(ans)); nprotect++;
use_names = !isNull(nm);
if (use_names) {
posn = INTEGER(PROTECT(matchnames(Snames,nm,"state variables"))); nprotect++;
}
ap = REAL(AS_NUMERIC(ans));
first = 0;
} else {
ap = REAL(AS_NUMERIC(eval(fcall,rho)));
}
if (use_names) {
for (i = 0; i < nvars; i++) xm[posn[i]] = ap[i];
} else {
for (i = 0; i < nvars; i++) xm[i] = ap[i];
}
}
break;
case native: // native code
(*ff)(xm,pm,sidx,pidx,cidx,ncovars,cp,t,dt);
break;
default:
errorcall(R_NilValue,"unrecognized 'mode' %d",mode); // # nocov
break;
}
}
t += dt;
if ((meth == 0) && (k == nstep-2)) { // penultimate step
dt = time[step]-t;
t = time[step]-dt;
}
}
}
}
if (mode==1) {
PutRNGstate();
unset_pomp_userdata();
}
UNPROTECT(nprotect);
return X;
}
SEXP lik4bin(SEXP data, SEXP star, SEXP sigma, SEXP thr, SEXP var, SEXP power, SEXP restringi, SEXP tsp)
{
double *Pdata, *Psigma, *Pstar, Pres[22], *Rres, *wstar, *age1, *age2;
double *Teff, *logg, *z, *M, *R, *Dni, *nimax, *logage, *pcage;
double Vthr, maxL, maxL1, maxL2, lmult, EXP, rpcage;
long nrow, ncol, count;
double sq2pi, chi[NVAR], locsigma[NVAR], chi2, mult, L, mass,
radius, lt, ltnlog;;
double sTeffP, sTeffM, time1, time2;
SEXP res, dm, sel;
long i, j, nres, nres1, nres2, DIM, start, n, startT, stopT, up, low;
int ii, norun, nstar, *Psel, *Pvar, restr;
DATA5 *d, *d1, *d2, *d3, *d4;
long lb, ub;
double t_spread; // max diff. in age
// cast and pointers
PROTECT(data = AS_NUMERIC(data));
PROTECT(star = AS_NUMERIC(star));
PROTECT(sigma = AS_NUMERIC(sigma));
PROTECT(thr = AS_NUMERIC(thr));
PROTECT(var = AS_INTEGER(var));
PROTECT(power = AS_NUMERIC(power));
PROTECT(restringi = AS_INTEGER(restringi));
PROTECT(tsp = AS_NUMERIC(tsp));
Pdata = NUMERIC_POINTER(data);
Pstar = NUMERIC_POINTER(star);
Psigma = NUMERIC_POINTER(sigma);
Vthr = NUMERIC_VALUE(thr);
Pvar = INTEGER_POINTER(var);
EXP = NUMERIC_VALUE(power);
restr = NUMERIC_VALUE(restringi);
t_spread = NUMERIC_VALUE(tsp);
// sqrt ( 2 * pi )
sq2pi = 2.506628274631000;
// dataset dimensions
nrow = INTEGER(GET_DIM(data))[0];
ncol = INTEGER(GET_DIM(data))[1];
// column pointers
// data are column ordered!
Teff = Pdata;
logg = Pdata+nrow;
z = Pdata+2*nrow;
Dni = Pdata+3*nrow;
nimax = Pdata+4*nrow;
M = Pdata+5*nrow;
R = Pdata+6*nrow;
logage = Pdata+7*nrow;
pcage = Pdata+8*nrow;
// vector for likelihood computations
// 1 = include; 0 = exclude
Psel = (int*)malloc(nrow*sizeof(int));
for(nstar=0;nstar<2;nstar++)
{
for(j=0;j<nrow;j++)
Psel[j] = 0;
wstar = &Pstar[(nstar)*9];
// sigma scaling for Dni,nimax,M,R (it is a % in input)
for(n=0;n<NVAR;n++)
locsigma[n] = Psigma[n+NVAR*nstar];
for(n=3;n<7;n++)
locsigma[n] *= wstar[n];
mult = 1;
for(n=0;n<NVAR;n++)
if(Pvar[n] == 1)
mult *= 1.0/(sq2pi * locsigma[n]);
lmult = log(mult);
// allowed Teff interval
sTeffP = wstar[0] + Vthr*locsigma[0];
sTeffM = wstar[0] - Vthr*locsigma[0];
// ricerca righe con Teff minima e massima
findrange(Teff, nrow, sTeffM, sTeffP, &startT, &stopT);
if(startT == -1 || stopT == -1)
{
free(Psel);
UNPROTECT(8);
return(R_NilValue);
}
// sel computation
nres = 0;
for(j=startT;j<=stopT;j++)
{
for(ii=0;ii<NVAR;ii++)
chi[ii] = 0;
if(Pvar[0] == 1)
chi[0] = (Teff[j] - wstar[0])/locsigma[0];
if(Pvar[1] == 1)
chi[1] = (logg[j] - wstar[1])/locsigma[1];
if(Pvar[2] == 1)
chi[2] = (z[j] - wstar[2])/locsigma[2];
if(Pvar[3] == 1)
chi[3] = (Dni[j] - wstar[3])/locsigma[3];
if(Pvar[4] == 1)
chi[4] = (nimax[j] - wstar[4])/locsigma[4];
if(Pvar[5] == 1)
chi[5] = (M[j] - wstar[5])/locsigma[5];
if(Pvar[6] == 1)
chi[6] = (R[j] - wstar[6])/locsigma[6];
norun = 0;
for(ii=0;ii<NVAR;ii++)
{
if(fabs(chi[ii]) >= Vthr)
{
norun = 1;
break;
}
}
if( norun == 0 )
{
chi2 = 0;
for(ii=0;ii<NVAR;ii++)
chi2 += chi[ii]*chi[ii];
if( restr == 1 )
{
if(sqrt(chi2) <= 3 )
{
nres++;
Psel[j] = 1;
}
}
else
{
nres++;
Psel[j] = 1;
}
}
}
// no data! return
if(nres == 0)
{
free(Psel);
UNPROTECT(8);
return(R_NilValue);
}
// init output matrix
DIM = nres;
if(nstar == 0)
{
d1 = (DATA5 *)calloc(DIM+1, sizeof(DATA5));
d = d1;
}
else
{
d2 = (DATA5 *)calloc(DIM+1, sizeof(DATA5));
d = d2;
}
// compute lik only if sel = 1
nres = 0;
maxL = 0;
for(j=startT;j<=stopT;j++)
{
if( Psel[j] == 1 )
{
for(ii=0;ii<NVAR;ii++)
chi[ii] = 0;
if(Pvar[0] == 1)
chi[0] = (Teff[j] - wstar[0])/locsigma[0];
if(Pvar[1] == 1)
chi[1] = (logg[j] - wstar[1])/locsigma[1];
if(Pvar[2] == 1)
chi[2] = (z[j] - wstar[2])/locsigma[2];
if(Pvar[3] == 1)
chi[3] = (Dni[j] - wstar[3])/locsigma[3];
if(Pvar[4] == 1)
chi[4] = (nimax[j] - wstar[4])/locsigma[4];
if(Pvar[5] == 1)
chi[5] = (M[j] - wstar[5])/locsigma[5];
if(Pvar[6] == 1)
chi[6] = (R[j] - wstar[6])/locsigma[6];
chi2 = 0;
for(n=0;n<NVAR;n++)
chi2 += chi[n]*chi[n];
// likelihood
L = mult * exp(-0.5*chi2);
if(L > maxL)
maxL = L;
d[nres].L = L;
d[nres].M = M[j];
d[nres].R = R[j];
d[nres].logage = logage[j];
d[nres].pcage = pcage[j];
nres++;
}
}
if(nstar==0)
{
nres1 = nres;
maxL1 = maxL;
}
else
{
nres2 = nres;
maxL2 = maxL;
}
}
// independent estimates
for(nstar=0;nstar<2;nstar++)
{
mass = radius = lt = ltnlog = rpcage = 0;
count = 0;
if(nstar==0)
{
nres = nres1;
maxL = maxL1;
d = d1;
}
else
{
nres = nres2;
maxL = maxL2;
d = d2;
}
// select only points with L >= 0.95 maxL
for(j=0;j<nres;j++)
{
if(d[j].L >= 0.95*maxL)
{
mass += d[j].M;
radius += d[j].R;
lt += d[j].logage;
rpcage += d[j].pcage;
ltnlog += 1e-9*pow(10, d[j].logage);
count++;
}
}
mass /= (double)(count);
radius /= (double)(count);
lt /= (double)(count);
ltnlog /= (double)(count);
rpcage /= (double)(count);
Pres[0+6*nstar] = mass;
Pres[1+6*nstar] = radius;
Pres[2+6*nstar] = lt;
Pres[3+6*nstar] = ltnlog;
Pres[4+6*nstar] = maxL;
Pres[5+6*nstar] = rpcage;
}
// joint estimates
qsort(d2, nres2, sizeof(DATA5), orderage);
age2 = (double*)malloc(nres2*sizeof(double));
age1 = (double*)malloc(nres1*sizeof(double));
for(i=0;i<nres1;i++)
age1[i] = 1e-9*pow(10, d1[i].logage);
for(i=0;i<nres2;i++)
age2[i] = 1e-9*pow(10, d2[i].logage);
maxL = 0;
for(j=0;j<nres1;j++)
{
findrange(age2, nres2, age1[j]-t_spread,age1[j]+t_spread, &lb, &ub);
// the joint estimate is impossible
if(lb == -1 || ub == -1) continue;
if(lb == ub && fabs(age1[j] - age2[lb]) > t_spread) continue;
for(i=lb;i<=ub;i++)
{
count++;
L = d1[j].L * d2[i].L;
if(L > maxL)
maxL = L;
}
}
for(j=12;j<22;j++)
Pres[j] = 0;
count = 0;
for(j=0;j<nres1;j++)
{
findrange(age2, nres2, age1[j]-t_spread,age1[j]+t_spread, &lb, &ub);
if(lb == -1 || ub == -1) continue;
if(lb == ub && fabs(age1[j] - age2[lb]) > t_spread) continue;
for(i=lb;i<=ub;i++)
{
L = d1[j].L * d2[i].L;
if(L > 0.95*maxL)
{
Pres[12] += d1[j].M;
Pres[13] += d1[j].R;
Pres[14] += d1[j].logage;
Pres[15] += age1[j];
Pres[16] += d2[i].M;
Pres[17] += d2[i].R;
Pres[18] += d2[i].logage;
Pres[19] += age2[i];
Pres[21] += d1[j].pcage;
count++;
}
}
}
Pres[20] = (double)count;
for(j=12;j<20;j++)
Pres[j] /= (double)(count);
Pres[21] /= (double)(count);
PROTECT( res = NEW_NUMERIC(22) );
Rres = NUMERIC_POINTER(res);
for(j=0;j<22;j++)
Rres[j] = Pres[j];
free(d1);
free(d2);
free(Psel);
free(age1);
free(age2);
// exit
UNPROTECT(9);
return(res);
}
SEXP estimate_trace(SEXP A, SEXP n, SEXP lambdamin, SEXP lambdamax, SEXP tol, SEXP samples, SEXP reqCores, SEXP rz, SEXP ans)
{
int useCores, haveCores;
int i;
int nsamples;
double lmin, lmax;
double max_error;
int rows;
double *pA;
double *pans;
double *prz;
double sum=0;
SEXP list;
nsamples=INTEGER_VALUE(samples);
lmin=NUMERIC_VALUE(lambdamin);
lmax=NUMERIC_VALUE(lambdamax);
rows=INTEGER_VALUE(n);
max_error=NUMERIC_VALUE(tol);
useCores=INTEGER_VALUE(reqCores);
PROTECT(A=AS_NUMERIC(A));
pA=NUMERIC_POINTER(A);
PROTECT(ans=AS_NUMERIC(ans));
pans=NUMERIC_POINTER(ans);
PROTECT(rz=AS_NUMERIC(rz));
prz=NUMERIC_POINTER(rz);
/*
Set the number of threads
*/
#ifdef _OPENMP
//R_CStackLimit=(uintptr_t)-1;
haveCores=omp_get_num_procs();
if(useCores<=0 || useCores>haveCores) useCores=haveCores;
omp_set_num_threads(useCores);
#endif
#pragma omp parallel
{
/*Starts the work sharing construct*/
#pragma omp for reduction(+:sum) schedule(static)
for(i=0; i<nsamples; i++)
{
sum+=Bai(pA,&rows,&lmin, &lmax, &max_error,prz,&i);
}
}
*pans=(sum/(nsamples));
PROTECT(list=allocVector(VECSXP,1));
SET_VECTOR_ELT(list,0,ans);
UNPROTECT(4);
return(list);
}
SEXP addDouble(SEXP a, SEXP b) {
double aDouble = NUMERIC_VALUE(a);
double bDouble = NUMERIC_VALUE(b);
return ScalarReal(aDouble + bDouble);
}
SEXP
m_log_lambda(SEXP X1, SEXP X1_Columns, SEXP X1_Rows,
SEXP X2, SEXP X2_Columns,
SEXP realS, SEXP OPTSimplicit_noisevar,
SEXP hp_prior, SEXP hp_posterior) {
long datalen;
int dim1, dim2, ncentroids;
double *Mu_mu, *S2_mu, *Mu_bar, *Mu_tilde,
*Alpha_ksi, *Beta_ksi, *Ksi_alpha, *Ksi_beta, *U_p, *prior_alpha,
*post_gamma, *log_lambda;
double *data1;
double *data2;
SEXP olog_lambda, oU_hat;
SEXP* U_hat;
double *Ns;
double implicit_noisevar;
/******************** input variables ********************/
/************ CONVERTED input variables ******************/
/* data */
PROTECT(X1 = AS_NUMERIC(X1));
data1 = NUMERIC_POINTER(X1);
dim1 = INTEGER_VALUE(X1_Columns);
datalen = INTEGER_VALUE(X1_Rows);
PROTECT(X2 = AS_NUMERIC(X2));
data2 = NUMERIC_POINTER(X2);
dim2 = INTEGER_VALUE(X2_Columns);
Ns = NUMERIC_POINTER(realS);
implicit_noisevar = NUMERIC_VALUE(OPTSimplicit_noisevar);
/* Converted Initial Values of Model Parameters */
if(dim1) {
Mu_mu = NUMERIC_POINTER(getListElement(hp_prior,"Mu_mu"));
S2_mu = NUMERIC_POINTER(getListElement(hp_prior,"S2_mu"));
Alpha_ksi = NUMERIC_POINTER(getListElement(hp_prior,"Alpha_ksi"));
Beta_ksi = NUMERIC_POINTER(getListElement(hp_prior,"Beta_ksi"));
Mu_bar = NUMERIC_POINTER(getListElement(hp_posterior,"Mu_bar"));
Mu_tilde = NUMERIC_POINTER(getListElement(hp_posterior,"Mu_tilde"));
Ksi_alpha = NUMERIC_POINTER(getListElement(hp_posterior,"Ksi_alpha"));
Ksi_beta = NUMERIC_POINTER(getListElement(hp_posterior,"Ksi_beta"));
}
if(dim2) {
U_p = NUMERIC_POINTER(getListElement(hp_prior,"U_p"));
oU_hat = getListElement(hp_posterior,"Uhat");
U_hat = &oU_hat;
}
prior_alpha = NUMERIC_POINTER(getListElement(hp_prior,"alpha"));
post_gamma = NUMERIC_POINTER(getListElement(hp_posterior,"gamma"));
ncentroids = INTEGER_POINTER( GET_DIM(getListElement(hp_posterior,"Mu_bar")) )[0];
/*printf("\nMu_mu ");
for(i=0; i< dim1;i++)
printf("%f ", Mu_mu[i]);
printf("\nS2_mu ");
for(i=0; i< dim1;i++)
printf("%f ", S2_mu[i]);
printf("\nAlpha_ksi ");
for(i=0; i< dim1;i++)
printf("%f ", Alpha_ksi[i]);
printf("\nBeta_ksi ");
for(i=0; i< dim1;i++)
printf("%f ", Beta_ksi[i]);
printf("\nMu_bar ");
for(i=0;i<ncentroids*dim1;i++)
printf("%f ", Mu_bar[i]);
printf("\nMu_tilde ");
for(i=0;i<ncentroids*dim1;i++)
printf("%f ", Mu_tilde[i]);
printf("\nKsi_alpha ");
for(i=0;i<ncentroids*dim1;i++)
printf("%f ", Ksi_alpha[i]);
printf("\nKsi_beta ");
for(i=0;i<ncentroids*dim1;i++)
printf("%f ", Ksi_beta[i]);
printf("\nprior_alpha = %f", *prior_alpha);
printf("\npost_gamma ");
for(i=0;i<2*ncentroids;i++)
printf("%f ", post_gamma[i]);
printf("ncentroids = %d\n", ncentroids);
printf("dim2 = %d\n",dim2);*/
/******************** output variables ********************/
PROTECT(olog_lambda = NEW_NUMERIC(datalen*ncentroids));
log_lambda = NUMERIC_POINTER(olog_lambda);
vdp_mk_log_lambda(Mu_mu, S2_mu, Mu_bar, Mu_tilde,
Alpha_ksi, Beta_ksi, Ksi_alpha, Ksi_beta,
post_gamma, log_lambda, prior_alpha,
U_p, U_hat,
datalen, dim1, dim2, data1, data2,
Ns, ncentroids, implicit_noisevar);
UNPROTECT(3);
return olog_lambda;
}
