Beispiel #1
0
/* ev_err -- reports error (err_num) in file "file" at line "line_num" and
   returns to user error handler;
   list_num is an error list number (0 is the basic list 
   pointed by err_mesg, 1 is the basic list of warnings)
 */
int	ev_err(char *file,int err_num,int line_num,char *fn_name,int list_num)
{
   int	num;
   
   if ( err_num < 0 ) err_num = 0;
   
#ifndef USING_R
   if (list_num < 0 || list_num >= err_list_end ||
       err_list[list_num].listp == (char **)NULL) {
      fprintf(stderr,
	      "\n Not (properly) attached list of errors: list_num = %d\n",
	      list_num);
      fprintf(stderr," Call \"err_list_attach\" in your program\n");
      if ( ! isatty(fileno(stdout)) ) {
	 fprintf(stderr,
		 "\n Not (properly) attached list of errors: list_num = %d\n",
		 list_num);
	 fprintf(stderr," Call \"err_list_attach\" in your program\n");
      }
      printf("\nExiting program\n");
      exit(0);
   }
#endif
   
   num = err_num;
   if ( num >= err_list[list_num].len ) num = 0;
   
#ifndef USING_R
   if ( cnt_errs && ++num_errs >= MAX_ERRS )	/* too many errors */
   {
      fprintf(stderr,"\n\"%s\", line %d: %s in function %s()\n",
	      file,line_num,err_list[list_num].listp[num],
	      isascii(*fn_name) ? fn_name : "???");
      if ( ! isatty(fileno(stdout)) )
	fprintf(stdout,"\n\"%s\", line %d: %s in function %s()\n",
		file,line_num,err_list[list_num].listp[num],
		isascii(*fn_name) ? fn_name : "???");
      printf("Sorry, too many errors: %d\n",num_errs);
      printf("Exiting program\n");
      exit(0);
   }
#endif
   if ( err_list[list_num].warn )
       switch ( err_flag )
       {
	   case EF_SILENT: break;
	   default:
#ifdef USING_R
	   Rprintf("\n\"%s\", line %d: %s in function %s()\n\n",
		   file,line_num,err_list[list_num].listp[num],
		   isascii(*fn_name) ? fn_name : "???");
#else
	   fprintf(stderr,"\n\"%s\", line %d: %s in function %s()\n\n",
		   file,line_num,err_list[list_num].listp[num],
		   isascii(*fn_name) ? fn_name : "???");
	   if ( ! isatty(fileno(stdout)) )
	       fprintf(stdout,"\n\"%s\", line %d: %s in function %s()\n\n",
		       file,line_num,err_list[list_num].listp[num],
		       isascii(*fn_name) ? fn_name : "???");
#endif
	   break;
       }
   else
       switch ( err_flag )
       {
	   case EF_SILENT:
	   longjmp(restart,(err_num==0)? -1 : err_num);
	   break;
	   case EF_ABORT:
#ifdef USING_R
	   Rprintf("\n\"%s\", line %d: %s in function %s()\n",
		   file,line_num,err_list[list_num].listp[num],
		   isascii(*fn_name) ? fn_name : "???");
#else
	   fprintf(stderr,"\n\"%s\", line %d: %s in function %s()\n",
		   file,line_num,err_list[list_num].listp[num],
		   isascii(*fn_name) ? fn_name : "???");
	   if ( ! isatty(fileno(stdout)) )
	       fprintf(stdout,"\n\"%s\", line %d: %s in function %s()\n",
		       file,line_num,err_list[list_num].listp[num],
		       isascii(*fn_name) ? fn_name : "???");
#endif
#ifdef USING_R
	   Rf_error("");
#else
	   abort();
#endif

	   break;
	   case EF_JUMP:
#ifdef USING_R
	   Rprintf("\n\"%s\", line %d: %s in function %s()\n",
		   file,line_num,err_list[list_num].listp[num],
		   isascii(*fn_name) ? fn_name : "???");
#else
	   fprintf(stderr,"\n\"%s\", line %d: %s in function %s()\n",
		   file,line_num,err_list[list_num].listp[num],
		   isascii(*fn_name) ? fn_name : "???");
	   if ( ! isatty(fileno(stdout)) )
	       fprintf(stdout,"\n\"%s\", line %d: %s in function %s()\n",
		       file,line_num,err_list[list_num].listp[num],
		       isascii(*fn_name) ? fn_name : "???");
#endif
	   longjmp(restart,(err_num==0)? -1 : err_num);
	   break;
	   case EF_R_ERROR:
#ifdef USING_R /* EJP */
	   Rprintf("\n\"%s\", line %d: %s in function %s()\n",
		   file,line_num,err_list[list_num].listp[num],
		   isascii(*fn_name) ? fn_name : "???");
		s_gstat_error(isascii(*fn_name) ? fn_name : "???", 0);
#endif
	   break;
	   default:
#ifdef USING_R
	   Rprintf("\n\"%s\", line %d: %s in function %s()\n\n",
		   file,line_num,err_list[list_num].listp[num],
		   isascii(*fn_name) ? fn_name : "???");
#else
	   fprintf(stderr,"\n\"%s\", line %d: %s in function %s()\n\n",
		   file,line_num,err_list[list_num].listp[num],
		   isascii(*fn_name) ? fn_name : "???");
	   if ( ! isatty(fileno(stdout)) )
	       fprintf(stdout,"\n\"%s\", line %d: %s in function %s()\n\n",
		       file,line_num,err_list[list_num].listp[num],
		       isascii(*fn_name) ? fn_name : "???");
#endif
	   break;
       }
   
   /* ensure exit if fall through */
   if ( ! err_list[list_num].warn )  
#ifdef USING_R /* EJP */
	 s_gstat_error("err.c", 0);
#else
  	 exit(0);
#endif

   return 0;
}
void convert_snp_affymetrix_C(char **dirname_, char **filelist, unsigned *files_amount_, char **map_filename_, char **outfilename_, unsigned *skipaffym, char **alleleID_names, char *alleleID, unsigned *alleleID_amount)
{

char *outfilename = *outfilename_;
char *dirname = *dirname_;
char *map_filename = *map_filename_;


unsigned files_amount=*files_amount_;



std::map<std::string, char> coding;
for(unsigned i=0 ; i<*alleleID_amount ; i++)
	{
	coding[alleleID_names[i]] = alleleID[i];
	}


Rprintf("reading map...\n");
//std::cout<<"reading map...\n";
AffymetrixChipMap Map(map_filename, 2, 0, 2, 4, 5, 3, 9, 10, 6);
//std::cout<<"map is read...\n";
Rprintf("map is read...\n");

if(Map.get_exclude_amount() != 0) 
	{
	Rprintf("%i SNPs excluded from annotation because of absent enough information annotation file\n", Map.get_exclude_amount());			
	}



std::vector<ChipData *> ids_chip;
for(unsigned i=0 ; i<files_amount ; i++)
	{
	std::string file = (std::string(dirname) + "/" + std::string(filelist[i]));
	Rprintf("%i: opening file %s\n", i+1, file.c_str());
	ids_chip.push_back(new affymetrix_chip_data(file, 0, 1, *skipaffym));
	}





unsigned id_amount=ids_chip.size(); 


std::ofstream outfile(outfilename);
if(!outfile.is_open()){error("Can not open file \"\"\n",outfilename);}


Rprintf("Save to file %s\n", outfilename);


outfile << "#GenABEL raw data version 0.1\n";

//save IDs
Rprintf("saving Id names...\n");
for(unsigned id=0 ; id<files_amount ; id++)
	{
	outfile<<replace(std::string(filelist[id]), ' ', '_')<<" ";
	}
outfile<<"\n";

std::string snpname;


unsigned long snp_excludet_from_output_data=0;


//save snpnames
Rprintf("saving SNP names...\n");
unsigned snp_amount=ids_chip[0]->get_snp_amount();
for(unsigned snp=0 ; snp<snp_amount ; snp++)
	{
	snpname = ids_chip[0]->get_snp_name(snp);
	if(Map.is_snp_in_map(snpname)){outfile<<Map.recode_snp(snpname.c_str())<<" ";}
	else{snp_excludet_from_output_data++;}
	}
outfile<<"\n";

//save chromosome 
Rprintf("saving chromosome data...\n");
for(unsigned snp=0 ; snp<snp_amount ; snp++)
	{
	snpname = ids_chip[0]->get_snp_name(snp);
	if(Map.is_snp_in_map(snpname)){outfile<<Map.get_chromosome(snpname.c_str())<<" ";}
	}
outfile<<"\n";


//save position (map) 
Rprintf("saving position data...\n");
for(unsigned snp=0 ; snp<snp_amount ; snp++)
	{
	snpname = ids_chip[0]->get_snp_name(snp);
	if(Map.is_snp_in_map(snpname)){outfile<<Map.get_phisical_position(snpname.c_str())<<" ";}
	}
outfile<<"\n";



//save coding
Rprintf("saving coding data...\n");
outfile.flags(std::ios_base::hex); //for what is it <-?
for(unsigned snp=0 ; snp<snp_amount ; snp++)
	{
	snpname = ids_chip[0]->get_snp_name(snp);
	if(Map.is_snp_in_map(snpname))
		{
		outfile.width(2);
		outfile.fill('0');
		static std::string allele_A, allele_B;
		allele_A = Map.get_allele_A(snpname.c_str());
  	allele_B = Map.get_allele_B(snpname.c_str());
		outfile<<unsigned(coding[allele_A+allele_B])<<" ";
		}
	}
outfile<<"\n";





//save strand
Rprintf("saving strand data...\n");
std::map<char, unsigned> strand_recode;
strand_recode['u']=0;
strand_recode['+']=1;
strand_recode['-']=2;

for(unsigned snp=0 ; snp<snp_amount ; snp++)
	{
	snpname = ids_chip[0]->get_snp_name(snp);
	if(Map.is_snp_in_map(snpname))
		{
		outfile.width(2);
		outfile.fill('0');
		static char strand;
		strand = Map.get_strand(snpname.c_str());
		outfile<<strand_recode[strand]<<" ";
		}
	}
outfile<<"\n";



//save polymorphism data
Rprintf("saving polymorphism data...\n");
unsigned long gtps_byte_amount = (unsigned long)ceil((double)id_amount/4.);
char *gtps_for_one_snp = new char[gtps_byte_amount];



unsigned *rearrangement_array = new unsigned[4];
rearrangement_array[0] = 6;
rearrangement_array[1] = 4;
rearrangement_array[2] = 2;
rearrangement_array[3] = 0;


for(unsigned snp=0 ; snp<snp_amount ; snp++)
	{
	if(!Map.is_snp_in_map(ids_chip[0]->get_snp_name(snp))) {continue;} // skip SNP if it doesn't exsist in our MAP
	for(unsigned i=0 ; i<gtps_byte_amount ; i++) gtps_for_one_snp[i]=0;
	
	static unsigned counter1, counter2;
	counter1=counter2=0;
	
	for(unsigned id=0 ; id<id_amount ; id++)
		{
		gtps_for_one_snp[counter2] = gtps_for_one_snp[counter2] | ids_chip[id]->get_polymorphism(snp)	<< rearrangement_array[counter1];
		counter1++;
		if(counter1==4) {counter1=0; counter2++;}
		}
		

	for(unsigned id=0 ; id<gtps_byte_amount ; id++)
		{
		outfile.width(2);
  	outfile.fill('0');
		outfile<<unsigned(gtps_for_one_snp[id]&0xFF)<<" ";
		}
	outfile<<"\n";
	}

delete gtps_for_one_snp;	
delete rearrangement_array;

Rprintf("%i SNPs excluded bacause of absent in annotation\n", snp_excludet_from_output_data);
Rprintf("Total %i SNPs are written into output file\n", snp_amount-snp_excludet_from_output_data);

Rprintf("Finshed... Data saved into file %s\n", outfilename);
outfile.close();
}
Beispiel #3
0
/* sbart() : The cubic spline smoother
   -------
 Calls	 sgram	(sg0,sg1,sg2,sg3,knot,nk)
	 stxwx	(xs,ys,ws,n,knot,nk,xwy,hs0,hs1,hs2,hs3)
	 sslvrg (penalt,dofoff,xs,ys,ws,ssw,n,knot,nk,	coef,sz,lev,crit,icrit,
		 lambda, xwy, hs0,hs1,hs2,hs3, sg0,sg1,sg2,sg3,
		 abd,p1ip,p2ip,ld4,ldnk,ier)

 is itself called from	 qsbart() [./qsbart.f]	 which has only one work array

 Now allows to pass 'lambda' (not just 'spar') via spar[0] == *spar  iff  *isetup = 2
*/
void F77_SUB(sbart)
    (double *penalt, double *dofoff,
     double *xs, double *ys, double *ws, double *ssw,
     int *n, double *knot, int *nk, double *coef,
     double *sz, double *lev, double *crit,
     int *icrit, double *spar, int *ispar, int *iter,
     double *lspar, double *uspar, double *tol, double *eps, double *Ratio,
     int *isetup,
     double *xwy, double *hs0, double *hs1, double *hs2,
     double *hs3, double *sg0, double *sg1, double *sg2,
     double *sg3, double *abd, double *p1ip, double *p2ip,
     int *ld4, int *ldnk, int *ier)
{

/* A Cubic B-spline Smoothing routine.

   The algorithm minimises:

	(1/n) * sum ws(i)^2 * (ys(i)-sz(i))^2 + lambda* int ( s"(x) )^2 dx

   lambda is a function of the spar which is assumed to be between 0 and 1

 INPUT
 -----
   penalt	A penalty > 1 to be used in the gcv criterion
   dofoff	either `df.offset' for GCV or `df' (to be matched).
   n		number of data points
   ys(n)	vector of length n containing the observations
   ws(n)	vector containing the weights given to each data point
		NB: the code alters the values here.
   xs(n)	vector containing the ordinates of the observations
   ssw          `centered weighted sum of y^2'
   nk		number of b-spline coefficients to be estimated
		nk <= n+2
   knot(nk+4)	vector of knot points defining the cubic b-spline basis.
		To obtain full cubic smoothing splines one might
		have (provided the xs-values are strictly increasing)
   spar		penalised likelihood smoothing parameter
   ispar	indicating if spar is supplied (ispar=1) or to be estimated
   lspar, uspar lower and upper values for spar search;  0.,1. are good values
   tol, eps	used in Golden Search routine
   isetup	setup indicator initially 0 or 2 (if 'spar' is lambda)
	NB: this alters that, and it is a constant in the caller!
   icrit	indicator saying which cross validation score is to be computed
		0: none ;  1: GCV ;  2: CV ;  3: 'df matching'
   ld4		the leading dimension of abd (ie ld4=4)
   ldnk		the leading dimension of p2ip (not referenced)

 OUTPUT
 ------
   coef(nk)	vector of spline coefficients
   sz(n)	vector of smoothed z-values
   lev(n)	vector of leverages
   crit		either ordinary or generalized CV score
   spar         if ispar != 1
   lspar         == lambda (a function of spar and the design if(setup != 1)
   iter		number of iterations needed for spar search (if ispar != 1)
   ier		error indicator
		ier = 0 ___  everything fine
		ier = 1 ___  spar too small or too big
			problem in cholesky decomposition

 Working arrays/matrix
   xwy			X'Wy
   hs0,hs1,hs2,hs3	the non-zero diagonals of the X'WX matrix
   sg0,sg1,sg2,sg3	the non-zero diagonals of the Gram matrix SIGMA
   abd (ld4, nk)	[ X'WX + lambda*SIGMA ] = R'R in banded form; output = R
   p1ip(ld4, nk)	inner products between columns of R^{-1}
   p2ip(ldnk,nk)	all inner products between columns of R inverse
			where  R'R = [X'WX + lambda*SIGMA]  NOT REFERENCED
*/

// "Correct" ./sslvrg.f (line 129):   crit = 3 + (dofoff-df)**2
#define CRIT(FX) (*icrit == 3 ? FX - 3. : FX)
	/* cancellation in (3 + eps) - 3, but still...informative */

#define BIG_f (1e100)

    /* c_Gold is the squared inverse of the golden ratio */
    static const double c_Gold = 0.381966011250105151795413165634;
    /* == (3. - sqrt(5.)) / 2. */

    /* Local variables */
    static double ratio;/* must be static (not needed in R) */

    double a, b, d, e, p, q, r, u, v, w, x;
    double ax, fu, fv, fw, fx, bx, xm;
    double tol1, tol2;

    int i, maxit;
    Rboolean Fparabol = FALSE, tracing = (*ispar < 0), spar_is_lambda = FALSE;

    /* unnecessary initializations to keep  -Wall happy */
    d = 0.; fu = 0.; u = 0.;
    // never computed if(spar_is_lambda)
    ratio = 1.;

/*  Compute SIGMA, X' W X, X' W z, trace ratio, s0, s1.

	SIGMA	-> sg0,sg1,sg2,sg3   -- via sgram() in ./sgram.f
	X' W X	-> hs0,hs1,hs2,hs3   \
	X' W Z	-> xwy               _\ via stxwx() in ./stxwx.f
*/

/* trevor fixed this 4/19/88
 * Note: sbart, i.e. stxwx() and sslvrg() {mostly, not always!}, use
 *	 the square of the weights; the following rectifies that */
    for (i = 0; i < *n; ++i)
	if (ws[i] > 0.)
	    ws[i] = sqrt(ws[i]);

    if (*isetup < 0)
	spar_is_lambda = TRUE;
    else if (*isetup != 1) { // 0 or 2
	/* SIGMA[i,j] := Int  B''(i,t) B''(j,t) dt  {B(k,.) = k-th B-spline} */
	F77_CALL(sgram)(sg0, sg1, sg2, sg3, knot, nk);
	F77_CALL(stxwx)(xs, ys, ws, n,
			knot, nk,
			xwy,
			hs0, hs1, hs2, hs3);
	spar_is_lambda = (*isetup == 2);
	if(!spar_is_lambda) {
	    /* Compute ratio :=  tr(X' W X) / tr(SIGMA) */
	    double t1 = 0., t2 = 0.;
	    for (i = 3 - 1; i < (*nk - 3); ++i) {
		t1 += hs0[i];
		t2 += sg0[i];
	    }
	    ratio = t1 / t2;
	}
	*isetup = 1;
    }
/*     Compute estimate */

// Compute SSPLINE(SPAR), assign result to *crit (and the auxil.variables)
#define SSPLINE_COMP(_SPAR_)						\
    *lspar = spar_is_lambda ? _SPAR_					\
                            : ratio * R_pow(16., (_SPAR_) * 6. - 2.);   \
    F77_CALL(sslvrg)(penalt, dofoff, xs, ys, ws, ssw, n,		\
		     knot, nk,						\
		     coef, sz, lev, crit, icrit, lspar, xwy,		\
		     hs0, hs1, hs2, hs3,				\
		     sg0, sg1, sg2, sg3, abd,				\
		     p1ip, p2ip, ld4, ldnk, ier)

    if (*ispar == 1) { /* Value of spar supplied */
	SSPLINE_COMP(*spar);
	/* got through check 2 */
	*Ratio = ratio;
	return;
    }

/* ELSE ---- spar not supplied --> compute it ! ---------------------------
 */
    ax = *lspar;
    bx = *uspar;

/*
       Use Forsythe Malcom and Moler routine to MINIMIZE criterion
       f denotes the value of the criterion

       an approximation	x  to the point where	f  attains a minimum  on
       the interval  (ax,bx)  is determined.


   INPUT

   ax	 left endpoint of initial interval
   bx	 right endpoint of initial interval
   f	 function subprogram which evaluates  f(x)  for any  x
	 in the interval  (ax,bx)
   tol	 desired length of the interval of uncertainty of the final
	 result ( >= 0 )

   OUTPUT

   fmin	 abcissa approximating the point where	f  attains a minimum
*/

/*
   The method used is a combination of  golden  section  search  and
   successive parabolic interpolation.	convergence is never much slower
   than	 that  for  a  fibonacci search.  if  f	 has a continuous second
   derivative which is positive at the minimum (which is not  at  ax  or
   bx),	 then  convergence  is	superlinear, and usually of the order of
   about  1.324....
	the function  f  is never evaluated at two points closer together
   than	 eps*abs(fmin) + (tol/3), where eps is	approximately the square
   root	 of  the  relative  machine  precision.	  if   f   is a unimodal
   function and the computed values of	 f   are  always  unimodal  when
   separated by at least  eps*abs(x) + (tol/3), then  fmin  approximates
   the abcissa of the global minimum of	 f  on the interval  ax,bx  with
   an error less than  3*eps*abs(fmin) + tol.  if   f	is not unimodal,
   then fmin may approximate a local, but perhaps non-global, minimum to
   the same accuracy.
	this function subprogram is a slightly modified	version	 of  the
   algol  60 procedure	localmin  given in richard brent, algorithms for
   minimization without derivatives, prentice - hall, inc. (1973).

   Double	 a,b,c,d,e,eps,xm,p,q,r,tol1,tol2,u,v,w
   Double	 fu,fv,fw,fx,x
*/

/*  eps is approximately the square root of the relative machine
    precision.

    -	 eps = 1e0
    - 10	 eps = eps/2e0
    -	 tol1 = 1e0 + eps
    -	 if (tol1 > 1e0) go to 10
    -	 eps = sqrt(eps)
    R Version <= 1.3.x had
    eps = .000244     ( = sqrt(5.954 e-8) )
     -- now eps is passed as argument
*/

    /* initialization */

    maxit = *iter;
    *iter = 0;
    a = ax;
    b = bx;
    v = a + c_Gold * (b - a);
    w = v;
    x = v;
    e = 0.;
    SSPLINE_COMP(x);
    fx = *crit;
    fv = fx;
    fw = fx;

/* main loop
   --------- */
    while(*ier == 0) { /* L20: */
	xm = (a + b) * .5;
	tol1 = *eps * fabs(x) + *tol / 3.;
	tol2 = tol1 * 2.;
	++(*iter);

	if(tracing) {
	    if(*iter == 1) {/* write header */
		Rprintf("sbart (ratio = %15.8g) iterations;"
			" initial tol1 = %12.6e :\n"
			"%11s %14s  %9s %11s  Kind %11s %12s\n%s\n",
			ratio, tol1, "spar",
			((*icrit == 1) ? "GCV" :
			 (*icrit == 2) ?  "CV" :
			 (*icrit == 3) ?"(df0-df)^2" :
			 /*else (should not happen) */"?f?"),
			"b - a", "e", "NEW lspar", "crit",
			" ---------------------------------------"
			"----------------------------------------");
	    }
	    Rprintf("%11.8f %14.9g %9.4e %11.5g", x, CRIT(fx), b - a, e);
	    Fparabol = FALSE;
	}

	/* Check the (somewhat peculiar) stopping criterion: note that
	   the RHS is negative as long as the interval [a,b] is not small:*/
	if (fabs(x - xm) <= tol2 - (b - a) * .5 || *iter > maxit)
	    goto L_End;


/* is golden-section necessary */

	if (fabs(e) <= tol1 ||
	    /*  if had Inf then go to golden-section */
	    fx >= BIG_f || fv >= BIG_f || fw >= BIG_f) goto L_GoldenSect;

/* Fit Parabola */
	if(tracing) { Rprintf(" FP"); Fparabol = TRUE; }

	r = (x - w) * (fx - fv);
	q = (x - v) * (fx - fw);
	p = (x - v) * q - (x - w) * r;
	q = (q - r) * 2.;
	if (q > 0.)
	    p = -p;
	q = fabs(q);
	r = e;
	e = d;

/* is parabola acceptable?  Otherwise do golden-section */

	if (fabs(p) >= fabs(.5 * q * r) ||
	    q == 0.)
	    /* above line added by BDR;
	     * [the abs(.) >= abs() = 0 should have branched..]
	     * in FTN: COMMON above ensures q is NOT a register variable */

	    goto L_GoldenSect;

	if (p <= q * (a - x) ||
	    p >= q * (b - x))			goto L_GoldenSect;



/* Parabolic Interpolation step */

	if(tracing) Rprintf(" PI ");
	d = p / q;
	if(!R_FINITE(d))
	    REprintf(" !FIN(d:=p/q): ier=%d, (v,w, p,q)= %g, %g, %g, %g\n",
		     *ier, v,w, p, q);
	u = x + d;

	/* f must not be evaluated too close to ax or bx */
	if (u - a < tol2 ||
	    b - u < tol2)	d = fsign(tol1, xm - x);

	goto L50;
	/*------*/

    L_GoldenSect: /* a golden-section step */

	if(tracing) Rprintf(" GS%s ", Fparabol ? "" : " --");

	if (x >= xm)    e = a - x;
	else/* x < xm*/ e = b - x;
	d = c_Gold * e;


    L50:
	u = x + ((fabs(d) >= tol1) ? d : fsign(tol1, d));
	/*  tol1 check : f must not be evaluated too close to x */

	SSPLINE_COMP(u);
	fu = *crit;
	if(tracing) Rprintf("%11g %12g\n", *lspar, CRIT(fu));
	if(!R_FINITE(fu)) {
	    REprintf("spar-finding: non-finite value %g; using BIG value\n", fu);
	    fu = 2. * BIG_f;
	}

/*  update  a, b, v, w, and x */

	if (fu <= fx) {
	    if (u >= x) a = x; else b = x;

	    v = w; fv = fw;
	    w = x; fw = fx;
	    x = u; fx = fu;
	}
	else {
	    if (u < x)  a = u; else b = u;

	    if (fu <= fw || w == x) {		        /* L70: */
		v = w; fv = fw;
		w = u; fw = fu;
	    } else if (fu <= fv || v == x || v == w) {	/* L80: */
		v = u; fv = fu;
	    }
	}
    }/* end main loop -- goto L20; */

 L_End:
    if(tracing) Rprintf("  >>> %12g %12g\n", *lspar, CRIT(fx));
    *Ratio = ratio;
    *spar = x;
    *crit = fx;
    return;
} /* sbart */
Beispiel #4
0
/**
 * utility function to print out division lines 
 */
static R_INLINE void print_line(){
  Rprintf("-----------------------------------------\n");
}
Beispiel #5
0
void _computeItemTrace(vector<double> &itemtrace, const NumericMatrix &Theta,
    const List &pars, const NumericVector &ot, const vector<int> &itemloc, const int &which,
    const int &nfact, const int &N, const int &USEFIXED)
{
    NumericMatrix theta = Theta;
    int nfact2 = nfact;
    S4 item = pars[which];
    int ncat = as<int>(item.slot("ncat"));
    vector<double> par = as< vector<double> >(item.slot("par"));
    vector<double> P(N*ncat);
    int itemclass = as<int>(item.slot("itemclass"));
    int correct = 0;
    if(itemclass == 8)
        correct = as<int>(item.slot("correctcat"));

    /*
        1 = dich
        2 = graded
        3 = gpcm
        4 = nominal
        5 = grsm
        6 = rsm
        7 = partcomp
        8 = nestlogit
        9 = custom....have to do in R for now
    */

    if(USEFIXED){
        NumericMatrix itemFD = item.slot("fixed.design");
        nfact2 = nfact + itemFD.ncol();
        NumericMatrix NewTheta(Theta.nrow(), nfact2);
        for(int i = 0; i < itemFD.ncol(); ++i)
            NewTheta(_,i) = itemFD(_,i);
        for(int i = 0; i < nfact; ++i)
            NewTheta(_,i+itemFD.ncol()) = Theta(_,i);
        theta = NewTheta;
    }
    switch(itemclass){
        case 1 :
            P_dich(P, par, theta, ot, N, nfact2);
            break;
        case 2 :
            P_graded(P, par, theta, ot, N, nfact2, ncat-1, 1, 0);
            break;
        case 3 :
            P_nominal(P, par, theta, ot, N, nfact2, ncat, 0, 0);
            break;
        case 4 :
            P_nominal(P, par, theta, ot, N, nfact2, ncat, 0, 0);
            break;
        case 5 :
            P_graded(P, par, theta, ot, N, nfact2, ncat-1, 1, 1);
            break;
        case 6 :
            P_nominal(P, par, theta, ot, N, nfact2, ncat, 0, 1);
            break;
        case 7 :
            P_comp(P, par, theta, N, nfact2);
            break;
        case 8 :
            P_nested(P, par, theta, N, nfact2, ncat, correct);
            break;
        case 9 :
            break;
        default :
            Rprintf("How in the heck did you get here from a switch statement?\n");
            break;
    }
    int where = (itemloc[which]-1) * N;
    for(int i = 0; i < N*ncat; ++i)
        itemtrace[where + i] = P[i];
}
Beispiel #6
0
void AllStatistics (
       int *tails, 
       int *heads,
       int *dnedges,
		   int *dn, /* Number of nodes */
       int *dflag, /* directed flag */
       int *bipartite,
       int *nterms, 
		   char **funnames, 
       char **sonames, 
       double *inputs,  
       double *covmat,
		   int *weightsvector,
       int *maxNumDyadTypes) {
  Network *nwp;

  Vertex n_nodes = (Vertex) *dn; 
  unsigned int directed_flag = *dflag;
  Vertex nodelistlength, rowmax, *nodelist1, *nodelist2;
  Vertex bip = (Vertex) *bipartite;
  Model *m;
  ModelTerm *mtp;

  /* Step 1:  Initialize empty network and initialize model */
  GetRNGstate(); /* Necessary for R random number generator */
  nwp=NetworkInitialize((Vertex*)tails, (Vertex*)heads, *dnedges,
		       n_nodes, directed_flag, bip, 0, 0, NULL);
  m=ModelInitialize(*funnames, *sonames, &inputs, *nterms);
  
  /* Step 2:  Build nodelist1 and nodelist2, which together give all of the
  dyads in the network. */
  if (BIPARTITE > 0) { /* Assuming undirected in the bipartite case */
    nodelistlength = BIPARTITE * (N_NODES-BIPARTITE);
    rowmax = BIPARTITE + 1;
  } else {
    nodelistlength = N_NODES * (N_NODES-1) / (DIRECTED? 1 : 2);
    rowmax = N_NODES;
  }
  nodelist1 = (Vertex *) R_alloc(nodelistlength, sizeof(int));
  nodelist2 = (Vertex *) R_alloc(nodelistlength, sizeof(int));
  int count = 0;
  for(int i=1; i < rowmax; i++) {
    for(int j = MAX(i,BIPARTITE)+1; j <= N_NODES; j++) {
      for(int d=0; d <= DIRECTED; d++) { /*trivial loop if undirected*/
        nodelist1[count] = d==1? j : i;
        nodelist2[count] = d==1? i : j;
        count++;
      }
    }
  }

  /* Step 3:  Initialize values of mtp->dstats so they point to the correct
  spots in the newRow vector.  These values will never change. */
  double *changeStats     = (double *) R_alloc(m->n_stats,sizeof(double));
  double *cumulativeStats = (double *) R_alloc(m->n_stats,sizeof(double));
  for (int i=0; i < m->n_stats; i++) cumulativeStats[i]=0.0;

  unsigned int totalStats = 0;
  for (mtp=m->termarray; mtp < m->termarray + m->n_terms; mtp++){
    mtp->dstats = changeStats + totalStats;
    /* Update mtp->dstats pointer to skip atail by mtp->nstats */
    totalStats += mtp->nstats; 
  }
  if (totalStats != m->n_stats) {
    Rprintf("I thought totalStats=%d and m->nstats=%d should be the same.\n", 
    totalStats, m->n_stats);
  }

  /* Step 4:  Begin recursion */
  RecurseOffOn(nodelist1, nodelist2, nodelistlength, 0, changeStats, 
	       cumulativeStats, covmat, (unsigned int*) weightsvector, *maxNumDyadTypes, nwp, m);

  /* Step 5:  Deallocate memory and return */
  ModelDestroy(m);
  NetworkDestroy(nwp);
  PutRNGstate(); /* Must be called after GetRNGstate before returning to R */
}
Beispiel #7
0
SEXP amcmc(SEXP Y, SEXP X,  SEXP Rweights, SEXP Rprobinit, SEXP Rmodeldim, SEXP incint, SEXP Ralpha,SEXP method, SEXP modelprior, SEXP Rupdate, SEXP Rbestmodel, SEXP plocal, SEXP BURNIN_Iterations, SEXP MCMC_Iterations, SEXP LAMBDA, SEXP DELTA)
{
  SEXP   Rse_m, Rcoef_m, Rmodel_m; 

  SEXP   RXwork = PROTECT(duplicate(X)), RYwork = PROTECT(duplicate(Y));

  int nProtected = 2, nUnique=0, newmodel=0;
  int nModels=LENGTH(Rmodeldim);
  
  //  Rprintf("Allocating Space for %d Models\n", nModels) ;
  SEXP ANS = PROTECT(allocVector(VECSXP, 15)); ++nProtected;
  SEXP ANS_names = PROTECT(allocVector(STRSXP, 15)); ++nProtected;
  SEXP Rprobs = PROTECT(duplicate(Rprobinit)); ++nProtected;
  SEXP MCMCprobs= PROTECT(duplicate(Rprobinit)); ++nProtected;
  SEXP R2 = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
  SEXP shrinkage = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
  SEXP modelspace = PROTECT(allocVector(VECSXP, nModels)); ++nProtected;
  SEXP modeldim =  PROTECT(duplicate(Rmodeldim)); ++nProtected;
  SEXP counts =  PROTECT(duplicate(Rmodeldim)); ++nProtected;
  SEXP beta = PROTECT(allocVector(VECSXP, nModels)); ++nProtected;
  SEXP se = PROTECT(allocVector(VECSXP, nModels)); ++nProtected;
  SEXP mse = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
  SEXP modelprobs = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
  SEXP priorprobs = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
  SEXP logmarg = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
  SEXP sampleprobs = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
  SEXP NumUnique = PROTECT(allocVector(INTSXP, 1)); ++nProtected;

  double *Xwork, *Ywork, *wts, *coefficients,*probs, shrinkage_m, *MCMC_probs,
    SSY, yty, mse_m, *se_m, MH=0.0, prior_m=1.0, *real_model, prob_i,
    R2_m, RSquareFull, alpha, prone, denom, logmargy, postold, postnew;
  int nobs, p, k, i, j, m, n, l, pmodel, pmodel_old, *xdims, *model_m, *bestmodel, *varin, *varout;
  int mcurrent,  update, n_sure;
  double  mod, rem, problocal, *pigamma, pigammaold, pigammanew, eps, *hyper_parameters;
  double *XtX, *XtY, *XtXwork, *XtYwork, *SSgam, *Cov, *priorCov, *marg_probs;
  double one=1.0, lambda,  delta, wt = 1.0; 
 
  int inc=1, print = 0;
  int *model, *modelold, bit, *modelwork, old_loc, new_loc;	
  struct Var *vars;	/* Info about the model variables. */
  NODEPTR tree, branch;

  /* get dimsensions of all variables */


  nobs = LENGTH(Y);
  xdims = INTEGER(getAttrib(X,R_DimSymbol));
  p = xdims[1];
  k = LENGTH(modelprobs);
  update = INTEGER(Rupdate)[0];
  lambda=REAL(LAMBDA)[0];
  delta = REAL(DELTA)[0];
  //  Rprintf("delta %f lambda %f", delta, lambda);
  eps = DBL_EPSILON;
  problocal = REAL(plocal)[0];
  //  Rprintf("Update %i and prob.switch %f\n", update, problocal);
  /* Extract prior on models  */
  hyper_parameters = REAL(getListElement(modelprior,"hyper.parameters"));

  /*  Rprintf("n %d p %d \n", nobs, p);  */

  Ywork = REAL(RYwork);
  Xwork = REAL(RXwork);
  wts = REAL(Rweights);
 
  PrecomputeData(Xwork, Ywork, wts, &XtXwork, &XtYwork, &XtX, &XtY, &yty, &SSY, p, nobs);

  alpha = REAL(Ralpha)[0];

  vars = (struct Var *) R_alloc(p, sizeof(struct Var));
  probs =  REAL(Rprobs);
  n = sortvars(vars, probs, p); 

  for (i =0; i <n; i++) REAL(MCMCprobs)[vars[i].index] = 0.0;
  MCMC_probs =  REAL(MCMCprobs);


  pigamma = vecalloc(p);
  real_model = vecalloc(n);
  marg_probs = vecalloc(n);
  modelold = ivecalloc(p);
  model = ivecalloc(p);
  modelwork= ivecalloc(p);
  varin= ivecalloc(p);
  varout= ivecalloc(p);


  /* create gamma gamma' matrix */
  SSgam  = (double *) R_alloc(n * n, sizeof(double));
  Cov  = (double *) R_alloc(n * n, sizeof(double));
  priorCov  = (double *) R_alloc(n * n, sizeof(double));
  for (j=0; j < n; j++) {
    for (i = 0; i < n; i++) {
      SSgam[j*n + i] = 0.0;
      Cov[j*n + i] = 0.0;
      priorCov[j*n + i] = 0.0;
      if (j == i)  priorCov[j*n + i] = lambda;
    }
    marg_probs[i] = 0.0;
  }


  /* Make space for the models and working variables. */ 

  /*  pivot = ivecalloc(p); 
  qraux = vecalloc(p);
  work =  vecalloc(2 * p);
  effects = vecalloc(nobs); 
  v =  vecalloc(p * p); 
  betaols = vecalloc(p);
  */

 

  /*  Rprintf("Fit Full Model\n"); */

  if (nobs <= p) {RSquareFull = 1.0;}
  else {
    PROTECT(Rcoef_m = NEW_NUMERIC(p));
    PROTECT(Rse_m = NEW_NUMERIC(p));
    coefficients = REAL(Rcoef_m);  
    se_m = REAL(Rse_m);
    memcpy(coefficients, XtY,  p*sizeof(double));
    memcpy(XtXwork, XtX, p*p*sizeof(double));
    memcpy(XtYwork, XtY,  p*sizeof(double));

    mse_m = yty; 
    cholreg(XtYwork, XtXwork, coefficients, se_m, &mse_m, p, nobs);  

  /*olsreg(Ywork, Xwork,  coefficients, se_m, &mse_m, &p, &nobs, pivot,qraux,work,residuals,effects,v, betaols); */
    RSquareFull =  1.0 - (mse_m * (double) ( nobs - p))/SSY;
    UNPROTECT(2);
  }


  /* fill in the sure things */
  for (i = n, n_sure = 0; i < p; i++)  {
      model[vars[i].index] = (int) vars[i].prob;
      if (model[vars[i].index] == 1) ++n_sure;
  }


  GetRNGstate();
  tree = make_node(-1.0);

  /*  Rprintf("For m=0, Initialize Tree with initial Model\n");  */

  m = 0;
  bestmodel = INTEGER(Rbestmodel);

  INTEGER(modeldim)[m] = n_sure;

  /* Rprintf("Create Tree\n"); */
   branch = tree;

   for (i = 0; i< n; i++) {
      bit =  bestmodel[vars[i].index];
      if (bit == 1) {
	if (i < n-1 && branch->one == NULL) 
	  branch->one = make_node(-1.0);
	if (i == n-1 && branch->one == NULL)
	  branch->one = make_node(0.0);
	branch = branch->one;
      }
      else {
	if (i < n-1 && branch->zero == NULL)
	  branch->zero = make_node(-1.0);
	if (i == n-1 && branch->zero == NULL)
	  branch->zero = make_node(0.0);
	branch = branch->zero;
      } 
      
      model[vars[i].index] = bit; 
      INTEGER(modeldim)[m]  += bit;
      branch->where = 0;
   }
  


    /*    Rprintf("Now get model specific calculations \n"); */
 
    pmodel = INTEGER(modeldim)[m];
    PROTECT(Rmodel_m = allocVector(INTSXP,pmodel));
    model_m = INTEGER(Rmodel_m);

      for (j = 0, l=0; j < p; j++) {  
	if (model[j] == 1) {
            model_m[l] = j;
           l +=1;}
      }

    SET_ELEMENT(modelspace, m, Rmodel_m);

    Rcoef_m = NEW_NUMERIC(pmodel); PROTECT(Rcoef_m);
    Rse_m = NEW_NUMERIC(pmodel);   PROTECT(Rse_m);
    coefficients = REAL(Rcoef_m);  
    se_m = REAL(Rse_m);

      for (j=0, l=0; j < pmodel; j++) {
        XtYwork[j] = XtY[model_m[j]];
        for  ( i = 0; i < pmodel; i++) {
	  XtXwork[j*pmodel + i] = XtX[model_m[j]*p + model_m[i]];
	}
      } 

      
    mse_m = yty; 
    memcpy(coefficients, XtYwork, sizeof(double)*pmodel); 
    cholreg(XtYwork, XtXwork, coefficients, se_m, &mse_m, pmodel, nobs);  

    R2_m = 1.0 - (mse_m * (double) ( nobs - pmodel))/SSY;

    SET_ELEMENT(beta, m, Rcoef_m);
    SET_ELEMENT(se, m, Rse_m);

    REAL(R2)[m] = R2_m;
    REAL(mse)[m] = mse_m;

    gexpectations(p, pmodel, nobs, R2_m, alpha, INTEGER(method)[0], RSquareFull, SSY, &logmargy, &shrinkage_m);
    REAL(sampleprobs)[m] = 1.0;
    REAL(logmarg)[m] = logmargy;
    REAL(shrinkage)[m] = shrinkage_m;
    prior_m = compute_prior_probs(model,pmodel,p, modelprior);
    REAL(priorprobs)[m] = prior_m;

    UNPROTECT(3);


    old_loc = 0;
    pmodel_old = pmodel;
    nUnique=1;
    INTEGER(counts)[0] = 0;
    postold =  REAL(logmarg)[m] + log(REAL(priorprobs)[m]);
    memcpy(modelold, model, sizeof(int)*p);
  /*   Rprintf("model %d max logmarg %lf\n", m, REAL(logmarg)[m]); */

    /*  Rprintf("Now Sample the Rest of the Models \n");  */
    
  
  m = 0;

  //  Need to fix in case the number of sampled models exceeds the space! 
  while (m < INTEGER(BURNIN_Iterations)[0]) {

    memcpy(model, modelold, sizeof(int)*p);
    pmodel =  n_sure;
    MH = 1.0;

    if (pmodel_old == n_sure || pmodel_old == n_sure + n){
	MH =  random_walk(model, vars,  n);
	MH =  1.0 - problocal;
    }
    else {
      if (unif_rand() < problocal) {
      // random
	MH =  random_switch(model, vars, n, pmodel_old, varin, varout );
      }
      else {
      // Randomw walk proposal flip bit//
	MH =  random_walk(model, vars,  n);
      }
    }
    
    branch = tree;
    newmodel= 0;

    for (i = 0; i< n; i++) {
      bit =  model[vars[i].index];
      
      if (bit == 1) {
	if (branch->one != NULL) branch = branch->one;
	else newmodel = 1;
	}
      else {
	if (branch->zero != NULL)  branch = branch->zero;
	else newmodel = 1.0;
      } 
      pmodel  += bit;
    }

    if (pmodel  == n_sure || pmodel == n + n_sure)  MH = 1.0/(1.0 - problocal);

    if (newmodel == 1) {
      new_loc = nUnique;
      PROTECT(Rmodel_m = allocVector(INTSXP,pmodel));
      model_m = INTEGER(Rmodel_m);
      for (j = 0, l=0; j < p; j++) {  
	if (model[j] == 1) {
	  model_m[l] = j;
	  l +=1;}
      }	

      Rcoef_m = NEW_NUMERIC(pmodel); PROTECT(Rcoef_m);
      Rse_m = NEW_NUMERIC(pmodel);   PROTECT(Rse_m);
      coefficients = REAL(Rcoef_m);  
      se_m = REAL(Rse_m);
      for (j=0, l=0; j < pmodel; j++) {
        XtYwork[j] = XtY[model_m[j]];
        for  ( i = 0; i < pmodel; i++) {
	  XtXwork[j*pmodel + i] = XtX[model_m[j]*p + model_m[i]];
	}	
      }	 

      mse_m = yty; 
      memcpy(coefficients, XtYwork, sizeof(double)*pmodel); 
      cholreg(XtYwork, XtXwork, coefficients, se_m, &mse_m, pmodel, nobs);  

      R2_m = 1.0 - (mse_m * (double) ( nobs - pmodel))/SSY;
      prior_m = compute_prior_probs(model,pmodel,p, modelprior);
      gexpectations(p, pmodel, nobs, R2_m, alpha, INTEGER(method)[0], RSquareFull, SSY, &logmargy, &shrinkage_m);
      postnew = logmargy + log(prior_m);
    }
    else {
      new_loc = branch->where;
      postnew =  REAL(logmarg)[new_loc] + log(REAL(priorprobs)[new_loc]);      
    } 

    MH *= exp(postnew - postold);
    //    Rprintf("MH new %lf old %lf\n", postnew, postold);
    if (unif_rand() < MH) {

      if (newmodel == 1)  {
	new_loc = nUnique;
	insert_model_tree(tree, vars, n, model, nUnique);

	INTEGER(modeldim)[nUnique] = pmodel;
	SET_ELEMENT(modelspace, nUnique, Rmodel_m);

	SET_ELEMENT(beta, nUnique, Rcoef_m);
	SET_ELEMENT(se, nUnique, Rse_m);

	REAL(R2)[nUnique] = R2_m;
	REAL(mse)[nUnique] = mse_m;
	REAL(sampleprobs)[nUnique] = 1.0;
	REAL(logmarg)[nUnique] = logmargy;
	REAL(shrinkage)[nUnique] = shrinkage_m;
	REAL(priorprobs)[nUnique] = prior_m;
	UNPROTECT(3);
	++nUnique; 
      }

      old_loc = new_loc;
      postold = postnew;
      pmodel_old = pmodel;
      memcpy(modelold, model, sizeof(int)*p);
    }
    else  {
      if (newmodel == 1) UNPROTECT(3);
    }

    INTEGER(counts)[old_loc] += 1;
    
    for (i = 0; i < n; i++) {
     real_model[i] = (double) modelold[vars[i].index];
     REAL(MCMCprobs)[vars[i].index] += (double) modelold[vars[i].index];
   }

   // Update SSgam = gamma gamma^T + SSgam 
   F77_NAME(dsyr)("U", &n,  &one, &real_model[0], &inc,  &SSgam[0], &n);
   m++;
  }
  
  //  Rprintf("\n%d Unique models sampled during burnin\n", nUnique);


// Compute marginal probabilities  
  mcurrent = nUnique;
  compute_modelprobs(modelprobs, logmarg, priorprobs,mcurrent);
  compute_margprobs(modelspace, modeldim, modelprobs, probs, mcurrent, p);        
  for (i = 0; i < n; i++) {
    marg_probs[i] = wt*(REAL(MCMCprobs)[vars[i].index]/ (double) m) + 
      (1.0 - wt)* probs[vars[i].index];
  }	
  //  print=1;
  update_Cov(Cov, priorCov, SSgam, marg_probs, n, m, print);
 
// Global-Proposal
// Initialize post old proposal
 pigammaold = 0.0;
 for (i = 0; i < n; i++) {
   if (modelold[vars[i].index] == 1 ){	
     real_model[i] = 1.0;
     pigammaold += log(cond_prob(real_model,i, n, marg_probs,Cov, delta));
   }
   else {
     real_model[i] = 0.0;
     pigammaold += log(1.0 - cond_prob(real_model,i, n, marg_probs,Cov, delta));
   }
 }
 
//  need to fix to make sure that nUnique is less than nModels 

 while (m < INTEGER(BURNIN_Iterations)[0] + INTEGER(MCMC_Iterations)[0]) {  
      // for (m = 0; m < k; m++) {
   memcpy(model, modelold, sizeof(int)*p);
   pmodel =  n_sure;
   MH = 1.0;
   pigammanew = 0.0;
   branch = tree;
   newmodel = 0;
   for (i = 0; i < n; i++) {
     prob_i = cond_prob(real_model,i, n, marg_probs,Cov,delta);
     bit =  withprob(prob_i);
     
     if (bit == 1) {
       pigammanew += log(prob_i);
       if (branch->one != NULL) branch = branch->one;
       else newmodel= 1;
     }
     else {
       pigammanew += log(1.0 - prob_i);
       if (branch->zero != NULL) branch = branch->zero;
       else newmodel= 1;
     } 
     model[vars[i].index] = bit; 
     real_model[i] = (double) bit;
     pmodel  += bit;
   }
   if (newmodel == 1) {
     new_loc = nUnique;
     PROTECT(Rmodel_m = allocVector(INTSXP,pmodel));
     model_m = INTEGER(Rmodel_m);
     for (j = 0, l=0; j < p; j++) {  
       if (model[j] == 1) {
	 model_m[l] = j;
	 l +=1;}
     }	

     Rcoef_m = NEW_NUMERIC(pmodel); PROTECT(Rcoef_m);
     Rse_m = NEW_NUMERIC(pmodel);   PROTECT(Rse_m);
     coefficients = REAL(Rcoef_m);  
     se_m = REAL(Rse_m);
     for (j=0, l=0; j < pmodel; j++) {
       XtYwork[j] = XtY[model_m[j]];
       for  ( i = 0; i < pmodel; i++) {
	 XtXwork[j*pmodel + i] = XtX[model_m[j]*p + model_m[i]];
       }		
      }	 

     mse_m = yty; 
     memcpy(coefficients, XtYwork, sizeof(double)*pmodel); 
     cholreg(XtYwork, XtXwork, coefficients, se_m, &mse_m, pmodel, nobs);  
     
     R2_m = 1.0 - (mse_m * (double) ( nobs - pmodel))/SSY;
     prior_m = compute_prior_probs(model,pmodel,p, modelprior);
     gexpectations(p, pmodel, nobs, R2_m, alpha, INTEGER(method)[0], RSquareFull, SSY, &logmargy, &shrinkage_m);
     postnew = logmargy + log(prior_m);
    }	
   else {
     new_loc = branch->where;
     postnew =  REAL(logmarg)[new_loc] + log(REAL(priorprobs)[new_loc]);      
   } 

   MH = exp(postnew - postold + pigammaold - pigammanew);
   // Rprintf("it %d MH %lf  new %lf old %lf propold %lf propnew %lf \n", m, MH, postnew, postold, pigammanew, pigammaold);
   if (unif_rand() < MH) {
     
     if (newmodel ==1)  {
       new_loc = nUnique;

       insert_model_tree(tree, vars, n, model, nUnique);

       INTEGER(modeldim)[nUnique] = pmodel;
       SET_ELEMENT(modelspace, nUnique, Rmodel_m);
       
       SET_ELEMENT(beta, nUnique, Rcoef_m);
       SET_ELEMENT(se, nUnique, Rse_m);
       
       REAL(R2)[nUnique] = R2_m;
       REAL(mse)[nUnique] = mse_m;
       
       REAL(logmarg)[nUnique] = logmargy;
       REAL(shrinkage)[nUnique] = shrinkage_m;
       REAL(priorprobs)[nUnique] = prior_m;
       UNPROTECT(3);
       ++nUnique; 
     }	

     old_loc = new_loc;
     pigammaold = pigammanew;
     REAL(sampleprobs)[old_loc] = pigammaold;
     postold = postnew;
     pmodel_old = pmodel;
     memcpy(modelold, model, sizeof(int)*p);
   }
   else  {
     if (newmodel == 1) UNPROTECT(3);
   }	
 
   INTEGER(counts)[old_loc] += 1;

   for (i = 0; i < n; i++) {
     real_model[i] = (double) modelold[vars[i].index];
     REAL(MCMCprobs)[vars[i].index] += (double) modelold[vars[i].index];
   }
   F77_NAME(dsyr)("U", &n,  &one, &real_model[0], &inc,  &SSgam[0], &n);
   m++;

   
   rem = modf((double) m/(double) update, &mod);
   if (rem  == 0.0) {
     mcurrent = nUnique;
     compute_modelprobs(modelprobs, logmarg, priorprobs,mcurrent);
     compute_margprobs(modelspace, modeldim, modelprobs, probs, mcurrent, p);        

     for (i = 0; i < n; i++) {
       marg_probs[i] = wt*(REAL(MCMCprobs)[vars[i].index]/ (double) m) + 
	 (1.0 - wt)*probs[vars[i].index];
     }
     update_Cov(Cov, priorCov, SSgam, marg_probs, n, m, print);
     // Initialize post old proposal
     pigammaold = 0.0;
     for (i = 0; i < n; i++) {
       if (modelold[vars[i].index] == 1 ){	
	 real_model[i] = 1.0;
	 pigammaold += log(cond_prob(real_model,i, n, marg_probs,Cov, delta));
       }
       else {
	 real_model[i] = 0.0;
	 pigammaold += log(1.0 - cond_prob(real_model,i, n, marg_probs,Cov, delta));
       }}
   }
 }

 mcurrent = nUnique;
 compute_modelprobs(modelprobs, logmarg, priorprobs,mcurrent);
 compute_margprobs(modelspace, modeldim, modelprobs, probs, mcurrent, p);        
 wt = 0.1;
 for (i = 0; i < n; i++) {
   marg_probs[i] = wt* (REAL(MCMCprobs)[vars[i].index]/ (double) m) + 
				    (1.0 - wt)*probs[vars[i].index];
   //  marg_probs[n-1-i] =  REAL(MCMCprobs)[vars[i].index]/ (double) m;
  REAL(MCMCprobs)[vars[i].index] /= (double) m;
  }

 update_Cov(Cov, priorCov, SSgam, marg_probs, n, m, print);

//  Now sample W/O Replacement 
// Rprintf("NumUnique Models Accepted %d \n", nUnique);
 INTEGER(NumUnique)[0] = nUnique;

 if (nUnique < k) {

    //    compute_modelprobs(modelprobs, logmarg, priorprobs,mcurrent);
    //    compute_margprobs(modelspace, modeldim, modelprobs, probs, mcurrent, p);        
    
   //   update_MCMC_probs(MCMC_probs, vars, n, p);
   //   Rprintf("Update Tree\n");

   update_cond_tree(modelspace, tree, modeldim, vars, p, n, nUnique, modelwork, real_model, marg_probs, Cov, eps);      
  
         
   //   Rprintf("\nNow sample the rest without replacement\n");
   
   for (m = nUnique; m < k; m++) {
     INTEGER(modeldim)[m]  = n_sure;
     
     branch = tree;
  
     for (i = 0; i< n; i++) {
       pigamma[i] = 1.0;

       if (branch->prob == -1.0) {
	 branch->prob = cond_prob(real_model,i, n, marg_probs,Cov, delta);
	 branch->update = m+mcurrent;
       }
       	 
       bit =  withprob(branch->prob);
       real_model[n-i-1] = (double) bit;
     
       if (bit == 1) {
	 for (j=0; j<=i; j++)  pigamma[j] *= branch->prob;
	 if (i < n-1 && branch->one == NULL) 
	 //	    branch->one = make_node(vars[i+1].prob);
	 branch->one = make_node(cond_prob(real_model,i+1, n, marg_probs,Cov , delta));
       if (i == n-1 && branch->one == NULL)
	 branch->one = make_node(0.0);
       branch = branch->one;
       }
     else {
       for (j=0; j<=i; j++)  pigamma[j] *= (1.0 - branch->prob);
       if (i < n-1 && branch->zero == NULL)
	 //	 branch->zero = make_node(vars[i+1].prob);
	 branch->zero = make_node(cond_prob(real_model,i+1, n, marg_probs,Cov, delta));
       if (i == n-1 && branch->zero == NULL)
	 branch->zero = make_node(0.0);
       branch = branch->zero;
     }
       model[vars[i].index] = bit; 
       INTEGER(modeldim)[m]  += bit;
     }

     REAL(sampleprobs)[m] = pigamma[0]; 

     pmodel = INTEGER(modeldim)[m];

    // Now subtract off the visited probability mass. 
     branch=tree;
     for (i = 0; i < n; i++) {
       bit = model[vars[i].index];
       prone = branch->prob;
       if (bit == 1) prone -= pigamma[i];
       denom = 1.0 - pigamma[i];
       if (denom <= 0.0) {
	 if (denom < 0.0) {
	   Rprintf("neg denominator %le %le %le !!!\n", pigamma, denom, prone);
	   if (branch->prob < 0.0 && branch->prob < 1.0)
	     Rprintf("non extreme %le\n", branch->prob);}
	 denom = 0.0;}
       else {
	 if  (prone <= 0)  prone = 0.0;
	 if  (prone > denom)  {
	   if (prone <= eps) prone = 0.0;
	   else prone = 1.0;
	  // Rprintf("prone > 1 %le %le %le %le !!!\n", pigamma, denom, prone, eps);
	 }
	 else prone = prone/denom;
       }
       if (prone > 1.0 || prone < 0.0) 
	 	 Rprintf("%d %d Probability > 1!!! %le %le  %le %le \n",
	 	 m, i, prone, branch->prob, denom, pigamma);
      //      if (bit == 1)  pigamma /= (branch->prob);
      //	      else  pigamma /= (1.0 - branch->prob); 
      //	      if (pigamma > 1.0) pigamma = 1.0; 
       branch->prob  = prone;
       if (bit == 1) branch = branch->one;
       else  branch = branch->zero;
      //      Rprintf("%d %d \n",  branch->done, n - i); 
      //      if (log((double) branch->done) < (n - i)*log(2.0)) {
      //	if (bit == 1) branch = branch->one;
      //	else  branch = branch->zero;
      //}
      //else {
      //	    branch->one = NULL;
      //	    branch->zero = NULL; 
      //	    break; } 
     }
    /* Now get model specific calculations */ 

    PROTECT(Rmodel_m = allocVector(INTSXP, pmodel));
    model_m = INTEGER(Rmodel_m);

    for (j = 0, l=0; j < p; j++) {  
      if (model[j] == 1) {
	model_m[l] = j;
	l +=1;}
      }	
 

      SET_ELEMENT(modelspace, m, Rmodel_m);
   
      for (j=0, l=0; j < pmodel; j++) {
	XtYwork[j] = XtY[model_m[j]];
        for  ( i = 0; i < pmodel; i++) {
	  XtXwork[j*pmodel + i] = XtX[model_m[j]*p + model_m[i]];
	}	
      } 

    
      PROTECT(Rcoef_m = allocVector(REALSXP,pmodel));
      PROTECT(Rse_m = allocVector(REALSXP,pmodel));
      coefficients = REAL(Rcoef_m);  
      se_m = REAL(Rse_m);
  
      mse_m = yty; 
      memcpy(coefficients, XtYwork, sizeof(double)*pmodel); 
      cholreg(XtYwork, XtXwork, coefficients, se_m, &mse_m, pmodel, nobs);  

  
    //    olsreg(Ywork, Xwork, coefficients, se_m, &mse_m, &pmodel, &nobs, pivot,qraux,work,residuals,effects,v,betaols);   
  
      R2_m = 1.0 - (mse_m * (double) ( nobs - pmodel))/SSY;

      SET_ELEMENT(beta, m, Rcoef_m);
      SET_ELEMENT(se, m, Rse_m);

      REAL(R2)[m] = R2_m;
      REAL(mse)[m] = mse_m;

   gexpectations(p, pmodel, nobs, R2_m, alpha, INTEGER(method)[0],  RSquareFull, SSY, &logmargy, &shrinkage_m);
   REAL(logmarg)[m] = logmargy;
   REAL(shrinkage)[m] = shrinkage_m;
   REAL(priorprobs)[m] = compute_prior_probs(model,pmodel,p, modelprior);
       
   UNPROTECT(3);  
   }	
 }


 // Rprintf("modelprobs\n");
 compute_modelprobs(modelprobs, logmarg, priorprobs,k);
 // Rprintf("marginal probs\n");
 compute_margprobs(modelspace, modeldim, modelprobs, probs, k, p);  
 
 // Rprintf("saving\n");
  SET_VECTOR_ELT(ANS, 0, Rprobs);
  SET_STRING_ELT(ANS_names, 0, mkChar("probne0"));

  SET_VECTOR_ELT(ANS, 1, modelspace);
  SET_STRING_ELT(ANS_names, 1, mkChar("which"));

  SET_VECTOR_ELT(ANS, 2, logmarg);
  SET_STRING_ELT(ANS_names, 2, mkChar("logmarg"));

  SET_VECTOR_ELT(ANS, 3, modelprobs);
  SET_STRING_ELT(ANS_names, 3, mkChar("postprobs"));

  SET_VECTOR_ELT(ANS, 4, priorprobs);
  SET_STRING_ELT(ANS_names, 4, mkChar("priorprobs"));

  SET_VECTOR_ELT(ANS, 5,sampleprobs);
  SET_STRING_ELT(ANS_names, 5, mkChar("sampleprobs"));

  SET_VECTOR_ELT(ANS, 6, mse);
  SET_STRING_ELT(ANS_names, 6, mkChar("mse"));

  SET_VECTOR_ELT(ANS, 7, beta);
  SET_STRING_ELT(ANS_names, 7, mkChar("mle"));

  SET_VECTOR_ELT(ANS, 8, se);
  SET_STRING_ELT(ANS_names, 8, mkChar("mle.se"));

  SET_VECTOR_ELT(ANS, 9, shrinkage);
  SET_STRING_ELT(ANS_names, 9, mkChar("shrinkage"));

  SET_VECTOR_ELT(ANS, 10, modeldim);
  SET_STRING_ELT(ANS_names, 10, mkChar("size"));
 
  SET_VECTOR_ELT(ANS, 11, R2);
  SET_STRING_ELT(ANS_names, 11, mkChar("R2"));

  SET_VECTOR_ELT(ANS, 12, counts);
  SET_STRING_ELT(ANS_names, 12, mkChar("freq"));

  SET_VECTOR_ELT(ANS, 13, MCMCprobs);
  SET_STRING_ELT(ANS_names, 13, mkChar("probs.MCMC"));

  SET_VECTOR_ELT(ANS, 14, NumUnique);
  SET_STRING_ELT(ANS_names, 14, mkChar("n.Unique"));

  setAttrib(ANS, R_NamesSymbol, ANS_names);
  UNPROTECT(nProtected);
  //  Rprintf("Return\n");
  PutRNGstate();

  return(ANS);  
}
Beispiel #8
0
void F77_SUB(rprintfi1)(char* msg, int *i) {
   Rprintf(msg, *i);
   Rprintf("\n");
}
Beispiel #9
0
void F77_SUB(rprintfi2)(char* msg, int *i1, int *i2) {
   Rprintf(msg, *i1, *i2);
   Rprintf("\n");
}
Beispiel #10
0
void F77_SUB(rprintfd1)(char* msg, double *d) {
   Rprintf(msg, *d);
   Rprintf("\n");
}
Beispiel #11
0
void F77_SUB(rprintfd2)(char* msg, double *d1, double *d2) {
   Rprintf(msg, *d1, *d2);
   Rprintf("\n");
}
Beispiel #12
0
void F77_SUB(rprintfdid)(char* msg, double *d1, int *i, double *d2) {
   Rprintf(msg, *d1, *i, *d2);
   Rprintf("\n");
}
Beispiel #13
0
void F77_SUB(rprintfdi)(char* msg, double *d, int *i) {
   Rprintf(msg, *d, *i);
   Rprintf("\n");
}
Beispiel #14
0
void F77_SUB(rprintfid)(char* msg, int *i, double *d) {
   Rprintf(msg, *i, *d);
   Rprintf("\n");
}
Beispiel #15
0
void R_test_call(DllInfo *info) {
  /* Register routines, allocate resources. */
  Rprintf("test_call DLL loaded\n");
}
Beispiel #16
0
void F77_SUB(rprintfi3)(char* msg, int *i1, int *i2, int* i3) {
   Rprintf(msg, *i1, *i2, *i3);
   Rprintf("\n");
}
Beispiel #17
0
void R_unload_test_call(DllInfo *info) {
  /* Release resources. */
  Rprintf("test_call DLL unloaded\n");
}
Beispiel #18
0
// may be redundant
void F77_SUB(rprintf2)(char* msg) {
   Rprintf(msg);
   Rprintf("\n");
}
Beispiel #19
0
SEXP call_stsparse(SEXP y, SEXP time, SEXP func, SEXP parms, SEXP forcs, 
    SEXP chtol, 
        SEXP atol, SEXP rtol, SEXP itol, SEXP rho, SEXP initfunc, SEXP initforc,
        SEXP verbose, SEXP NNZ, SEXP NSP, SEXP NGP, SEXP nIter, SEXP Posit,
    SEXP Pos, SEXP nOut, SEXP Rpar, SEXP Ipar, SEXP Type, SEXP Ian, SEXP Jan,
    SEXP Met, SEXP Option)
{
  SEXP   yout, RWORK, IWORK;
  int    j, k, ny, maxit, isSteady, method, lenplufac, lenplumx, lfill;
  double *svar, *dsvar, *beta, *alpha, tin, *Atol, *Rtol, Chtol;
  double *x, *precis, *ewt, droptol, permtol;
  int    neq, nnz, nsp, ngp, niter, mflag, posit, TotN, ipos, Itol, type;
  int    *ian, *jan, *igp, *jgp, *dims, *pos;
  int    len, isDll, ilumethod;

  double *rsp= NULL, *plu= NULL,  *rwork= NULL;
  int    *R= NULL, *C= NULL, *IC= NULL, *indDIM = NULL;
  int    *isp= NULL, *iwork= NULL, *iperm= NULL, *jlu= NULL, *ju= NULL; 

  C_deriv_func_type *derivs;
  init_N_Protect();

  nnz   = INTEGER(NNZ)[0];
  nsp   = INTEGER(NSP)[0];  
  ngp   = INTEGER(NGP)[0];  
  ny    = LENGTH(y);
  Itol  = INTEGER(itol)[0];
  maxit = INTEGER(nIter)[0];  
  type  = INTEGER(Type)[0];
  method = INTEGER(Met)[0];

  posit = INTEGER(Posit)[0];   /* positivity of state variables: either specified at once, or via a vector..*/
  ipos = LENGTH(Pos);
  pos = (int *) R_alloc(ipos, sizeof(int));
    for (j = 0; j < ipos; j++) pos[j] = INTEGER(Pos)[j];

  neq   = ny; 
  mflag = INTEGER(verbose)[0];

  if (inherits(func, "NativeSymbol"))  /* function is a dll */
     isDll = 1;
  else
     isDll = 0;
   if (nout > 0) isOut = 1; 

  /* initialise output ... */
  initOut(isDll, neq, nOut, Rpar, Ipar);

  /* initialise global variables... */
            
  PROTECT(Time = NEW_NUMERIC(1))                   ;incr_N_Protect(); 
  PROTECT(Y = allocVector(REALSXP, neq))           ;incr_N_Protect();        

  /* copies of all variables that will be changed in the FORTRAN subroutine */
  if (method == 1) {           /* yale sparse matrix solver */
    R = (int *) R_alloc(neq, sizeof(int));
     for (j = 0; j < ny; j++) R[j] = 0;
 
    C = (int *) R_alloc(neq, sizeof(int));
     for (j = 0; j < ny; j++) C[j] = 0;

    IC = (int *) R_alloc(neq, sizeof(int));
     for (j = 0; j < ny; j++) IC[j] = 0;

    rsp = (double *) R_alloc(nsp, sizeof(double));
     for (j = 0; j < nsp; j++) rsp[j] = 0.;

    isp = (int *) R_alloc(2*nsp, sizeof(int));
     for (j = 0; j < 2*nsp; j++) isp[j] = 0;
  } else {                    /* sparskit matrix solver */
    /* get options */
    lenplufac = INTEGER(getListElement(Option, "lenplufac"))[0];
    lfill     = INTEGER(getListElement(Option, "fillin")   )[0];
    droptol   = REAL   (getListElement(Option, "droptol")  )[0];
    permtol   = REAL   (getListElement(Option, "permtol")  )[0];

    ilumethod = method - 1; /* 1 = ilut, 2 = ilutp */
    lenplumx = nnz + lenplufac*neq;
    
    jlu = (int *) R_alloc(lenplumx, sizeof(int));
     for (j = 0; j < lenplumx; j++) jlu[j] = 0;

    ju = (int *) R_alloc(neq, sizeof(int));
     for (j = 0; j < neq; j++) ju[j] = 0;

    iwork = (int *) R_alloc(2*neq, sizeof(int));
     for (j = 0; j < 2*neq; j++) iwork[j] = 0;

    iperm = (int *) R_alloc(2*neq, sizeof(int));
     for (j = 0; j < 2*neq; j++) iperm[j] = 0;
 
    plu = (double *) R_alloc(lenplumx, sizeof(double));
     for (j = 0; j < lenplumx; j++) plu[j] = 0.;

    rwork = (double *) R_alloc(neq, sizeof(double));
     for (j = 0; j < neq; j++) rwork[j] = 0.;
  }

  dims = (int *) R_alloc(7, sizeof(int));   /* 7 is maximal amount */
    for (j = 0; j < 7; j++) dims[j] = 0;

  svar = (double *) R_alloc(neq, sizeof(double));
    for (j = 0; j < ny; j++) svar[j] = REAL(y)[j];

  dsvar = (double *) R_alloc(neq, sizeof(double));
    for (j = 0; j < ny; j++) dsvar[j] = 0; 

  beta = (double *) R_alloc(neq, sizeof(double));
    for (j = 0; j < ny; j++) beta[j] = 0; 

  x = (double *) R_alloc(neq, sizeof(double));
    for (j = 0; j < ny; j++) x[j] = 0; 

  alpha = (double *) R_alloc(nnz, sizeof(double));
    for (j = 0; j < nnz; j++) alpha[j] = 0; 

  ewt = (double *) R_alloc(neq, sizeof(double));
    for (j = 0; j < ny; j++) ewt[j] = 0; 

  ian = (int *) R_alloc(neq+1, sizeof(int));
   if (type == 0) {for (j = 0; j < neq; j++) ian[j] = INTEGER(Ian)[j];} 
   else {for (j = 0; j < neq; j++) ian[j] = 0;}

  jan = (int *) R_alloc(nnz, sizeof(int));
   if (type == 0) 
   {for (j = 0; j < nnz; j++) jan[j] = INTEGER(Jan)[j];} 
   else {for (j = 0; j < nnz; j++) jan[j] = 0;}
   
  /* 1-D, 2-D, 3-D problem:  */
  if (type == 2)        /* 1=ncomp,2:dim(x), 3: cyclic(x)*/
    for (j = 0; j<3 ; j++) dims[j] = INTEGER(NNZ)[j+1];
  else if (type == 3)   /* 1=ncomp,2-3:dim(x,y), 4-5: cyclic(x,y)*/
    for (j = 0; j<5 ; j++) dims[j] = INTEGER(NNZ)[j+1];
  else if (type == 4)   /* 1=ncomp,2-4:dim(x,y,z), 5-7: cyclic(x,y,z)*/
    for (j = 0; j<7 ; j++) dims[j] = INTEGER(NNZ)[j+1];
  else if (type == 30)  { /* same as type 3 (2-D) but with mapping */
    for (j = 0; j<5 ; j++) dims[j] = INTEGER(NNZ)[j+1];
    TotN = INTEGER(NNZ)[6];
	  indDIM = (int *) R_alloc(TotN, sizeof(int));
    for (j = 0; j < TotN ; j++) indDIM[j] = INTEGER(NNZ)[j+7];
  }  else if (type == 40)  { /* same as type 4 (3-D) but with mapping */
    for (j = 0; j<7 ; j++) dims[j] = INTEGER(NNZ)[j+1];
    TotN = INTEGER(NNZ)[8];
	  indDIM = (int *) R_alloc(TotN, sizeof(int));
    for (j = 0; j < TotN ; j++) indDIM[j] = INTEGER(NNZ)[j+9];
  }

  igp = (int *) R_alloc(ngp+1, sizeof(int));
    for (j = 0; j < ngp+1; j++) igp[j] = 0;
  
  jgp = (int *) R_alloc(neq, sizeof(int));
    for (j = 0; j < neq; j++) jgp[j] = 0;

  len = LENGTH(atol);  
  Atol = (double *) R_alloc(len, sizeof(double));
    for (j = 0; j < len; j++) Atol[j] = REAL(atol)[j];

  len = LENGTH(rtol);  
  Rtol = (double *) R_alloc(len, sizeof(double));
    for (j = 0; j < len; j++) Rtol[j] = REAL(rtol)[j];

  Chtol = REAL(chtol)[0];

  precis =(double *) R_alloc(maxit, sizeof(double));
    for (j = 0; j < maxit; j++) precis[j] = 0;
  
  PROTECT(yout = allocVector(REALSXP,ntot))    ; incr_N_Protect();

 /* The initialisation routine */
  initParms(initfunc, parms);
  initForcs(initforc, forcs);

 /* pointers to functions derivs and jac, passed to the FORTRAN subroutine */

  if (isDll)
    {
      derivs = (C_deriv_func_type *) R_ExternalPtrAddrFn_(func);

    } else {  derivs = (C_deriv_func_type *) C_stsparse_derivs;  
      PROTECT(stsparse_deriv_func = func); incr_N_Protect();
      PROTECT(stsparse_envir = rho);incr_N_Protect();
    }
    
    tin = REAL(time)[0];
      
  if (method == 1) {
      F77_CALL(dsparse) (derivs, &neq, &nnz, &nsp, &tin, svar, dsvar, beta, x,
         alpha, ewt, rsp, ian, jan, igp, jgp, &ngp, R, C, IC, isp,
         &maxit,  &Chtol, Atol, Rtol, &Itol, &posit, pos, &ipos, &isSteady,
         precis, &niter, dims, out, ipar, &type, indDIM);
  } else {
      F77_CALL(dsparsekit) (derivs, &neq, &nnz, &nsp, &tin, svar, dsvar, beta, x,
         alpha, ewt, ian, jan, igp, jgp, &ngp, jlu, ju, iwork, iperm,
         &maxit,  &Chtol, Atol, Rtol, &Itol, &posit, pos, &ipos, &isSteady,
         precis, &niter, dims, out, ipar, &type, &droptol, &permtol, &ilumethod,
         &lfill, &lenplumx, plu, rwork, indDIM);
  }
      for (j = 0; j < ny; j++)
        REAL(yout)[j] = svar[j];
   
      if (isOut == 1) 
    {
        derivs (&neq, &tin, svar, dsvar, out, ipar) ;
          for (j = 0; j < nout; j++)
           REAL(yout)[j + ny] = out[j]; 
    }
 
  PROTECT(RWORK = allocVector(REALSXP, niter));incr_N_Protect();
  for (k = 0;k<niter;k++) REAL(RWORK)[k] = precis[k];
  if (mflag == 1) Rprintf("mean residual derivative %g\n",precis[niter-1]);

  setAttrib(yout, install("precis"), RWORK);    

  PROTECT(IWORK = allocVector(INTSXP, 4));incr_N_Protect();
                          INTEGER(IWORK)[0]   = isSteady;
    for (k = 0; k<3; k++) INTEGER(IWORK)[k+1] = dims[k];
  
  setAttrib(yout, install("steady"), IWORK);    
       
  unprotect_all();
  return(yout);
}
Beispiel #20
0
/* browser(text = "", condition = NULL, expr = TRUE, skipCalls = 0L)
 * ------- but also called from ./eval.c */
SEXP attribute_hidden do_browser(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    RCNTXT *saveToplevelContext;
    RCNTXT *saveGlobalContext;
    RCNTXT thiscontext, returncontext, *cptr;
    int savestack, browselevel;
    SEXP ap, topExp, argList;

    /* argument matching */
    PROTECT(ap = list4(R_NilValue, R_NilValue, R_NilValue, R_NilValue));
    SET_TAG(ap,  install("text"));
    SET_TAG(CDR(ap), install("condition"));
    SET_TAG(CDDR(ap), install("expr"));
    SET_TAG(CDDDR(ap), install("skipCalls"));
    argList = matchArgs(ap, args, call);
    UNPROTECT(1);
    PROTECT(argList);
    /* substitute defaults */
    if(CAR(argList) == R_MissingArg)
	SETCAR(argList, mkString(""));
    if(CADR(argList) == R_MissingArg)
	SETCAR(CDR(argList), R_NilValue);
    if(CADDR(argList) == R_MissingArg) 
	SETCAR(CDDR(argList), ScalarLogical(1));
    if(CADDDR(argList) == R_MissingArg) 
	SETCAR(CDDDR(argList), ScalarInteger(0));

    /* return if 'expr' is not TRUE */
    if( !asLogical(CADDR(argList)) ) {
        UNPROTECT(1);
        return R_NilValue;
    }

    /* Save the evaluator state information */
    /* so that it can be restored on exit. */

    browselevel = countContexts(CTXT_BROWSER, 1);
    savestack = R_PPStackTop;
    PROTECT(topExp = R_CurrentExpr);
    saveToplevelContext = R_ToplevelContext;
    saveGlobalContext = R_GlobalContext;

    if (!RDEBUG(rho)) {
        int skipCalls = asInteger(CADDDR(argList));
	cptr = R_GlobalContext;
	while ( ( !(cptr->callflag & CTXT_FUNCTION) || skipCalls--) 
		&& cptr->callflag )
	    cptr = cptr->nextcontext;
	Rprintf("Called from: ");
	int tmp = asInteger(GetOption(install("deparse.max.lines"), R_BaseEnv));
	if(tmp != NA_INTEGER && tmp > 0) R_BrowseLines = tmp;
        if( cptr != R_ToplevelContext ) {
	    PrintValueRec(cptr->call, rho);
	    SET_RDEBUG(cptr->cloenv, 1);
        } else
            Rprintf("top level \n");

	R_BrowseLines = 0;
    }

    R_ReturnedValue = R_NilValue;

    /* Here we establish two contexts.  The first */
    /* of these provides a target for return */
    /* statements which a user might type at the */
    /* browser prompt.  The (optional) second one */
    /* acts as a target for error returns. */

    begincontext(&returncontext, CTXT_BROWSER, call, rho,
		 R_BaseEnv, argList, R_NilValue);
    if (!SETJMP(returncontext.cjmpbuf)) {
	begincontext(&thiscontext, CTXT_RESTART, R_NilValue, rho,
		     R_BaseEnv, R_NilValue, R_NilValue);
	if (SETJMP(thiscontext.cjmpbuf)) {
	    SET_RESTART_BIT_ON(thiscontext.callflag);
	    R_ReturnedValue = R_NilValue;
	    R_Visible = FALSE;
	}
	R_GlobalContext = &thiscontext;
	R_InsertRestartHandlers(&thiscontext, TRUE);
	R_ReplConsole(rho, savestack, browselevel+1);
	endcontext(&thiscontext);
    }
    endcontext(&returncontext);

    /* Reset the interpreter state. */

    R_CurrentExpr = topExp;
    UNPROTECT(1);
    R_PPStackTop = savestack;
    UNPROTECT(1);
    R_CurrentExpr = topExp;
    R_ToplevelContext = saveToplevelContext;
    R_GlobalContext = saveGlobalContext;
    return R_ReturnedValue;
}
Beispiel #21
0
/**
 * utility function to print out acceptance rates
 *
 * @param n number of iterations
 * @param p the length of acc
 * @param acc a vector that stores acceptance times or percentages
 * @param pct indicating whether acc is the acceptance percentage or the unscaled acceptance times
 *
 */
static R_INLINE void print_acc(int n, int p, double *acc, int pct){
  double C = (pct) ? 100 : (100.0/n);
  Rprintf(_("Acceptance rate: min(%4.2f%%), mean(%4.2f%%), max(%4.2f%%)\n"),
	  dmin(acc, p) * C, mean(acc, p) * C, dmax(acc, p) * C);     
}
Beispiel #22
0
/**
 * Main function for cwb-align-encode.
 *
 * @param argc   Number of command-line arguments.
 * @param argv   Command-line arguments.
 */
int
main(int argc, char *argv[])
{
  int argindex;                         /* index of first argument in argv[] */

  char *align_name = NULL;              /* name of the .align file */
  FILE *af = NULL;                      /* alignment file handle */
  int af_is_pipe;                       /* need to know whether to call fclose() or pclose() */
  char alx_name[CL_MAX_LINE_LENGTH];    /* full pathname of .alx file */
  char alg_name[CL_MAX_LINE_LENGTH];    /* full pathname of optional .alg file */
  FILE *alx=NULL, *alg=NULL;            /* file handles for .alx and optional .alg file */

  char line[CL_MAX_LINE_LENGTH];        /* one line of input from <infile> */

  char corpus1_name[CL_MAX_FILENAME_LENGTH];
  char corpus2_name[CL_MAX_FILENAME_LENGTH];
  char s1_name[CL_MAX_FILENAME_LENGTH];
  char s2_name[CL_MAX_FILENAME_LENGTH];
  Corpus *corpus1, *corpus2;            /* corpus handles */
  Attribute *w1, *w2;                   /* attribute handles for 'word' attributes; used to determine corpus size */
  int size1, size2;                     /* size of source & target corpus */

  Corpus *source_corpus;                /* encode alignment in this corpus (depends on -R flag, important for -D option) */
  char *source_corpus_name;             /* just for error messages */
  char *attribute_name;                 /* name of alignment attribute (depends on -R flag, must be lowercase) */

  int f1,l1,f2,l2;                      /* alignment regions */
  int current1, current2;
  int mark, n_0_1, n_1_0;

  int l;

  progname = argv[0];

  /* parse command line and read arguments */
  argindex = alignencode_parse_args(argc, argv, 1);
  align_name = argv[argindex];

  /* open alignment file and parse header; .gz files are automatically decompressed */
  af_is_pipe = 0;
  l = strlen(align_name);
  if ((l > 3) && (strncasecmp(align_name + l - 3, ".gz", 3) == 0)) {
    char *pipe_cmd = (char *) cl_malloc(l+10);
    sprintf(pipe_cmd, "gzip -cd %s", align_name); /* write .gz file through gzip pipe */
    af = popen(pipe_cmd, "r");
    if (af == NULL) {
      perror(pipe_cmd);
     Rprintf( "%s: can't read compressed file %s\n", progname, align_name);
      rcqp_receive_error(1);
    }
    af_is_pipe = 1;
    cl_free(pipe_cmd);
  }
  else {
    af = fopen(align_name, "r");
    if (af == NULL) {
      perror(align_name);
     Rprintf( "%s: can't read file %s\n", progname, align_name);
      rcqp_receive_error(1);
    }
  }

  /* read header = first line */
  fgets(line, CL_MAX_LINE_LENGTH, af);
  if (4 != sscanf(line, "%s %s %s %s", corpus1_name, s1_name, corpus2_name, s2_name)) {
   Rprintf( "%s: %s not in .align format\n", progname, align_name);
   Rprintf( "wrong header: %s", line);
    rcqp_receive_error(1);
  }
  if (verbose) {
    if (reverse)
     Rprintf("Encoding alignment for [%s, %s] from file %s\n", corpus2_name, corpus1_name, align_name);
    else
     Rprintf("Encoding alignment for [%s, %s] from file %s\n", corpus1_name, corpus2_name, align_name);
  }

  /* open corpora and determine their sizes (for validity checks and compatibility mode) */
  if (NULL == (corpus1 = cl_new_corpus(registry_dir, corpus1_name))) {
   Rprintf( "%s: can't open corpus %s\n", progname, corpus1_name);
    rcqp_receive_error(1);
  }
  if (NULL == (corpus2 = cl_new_corpus(registry_dir, corpus2_name))) {
   Rprintf( "%s: can't open corpus %s\n", progname, corpus2_name);
    rcqp_receive_error(1);
  }
  if (NULL == (w1 = cl_new_attribute(corpus1, "word", ATT_POS))) {
   Rprintf( "%s: can't open p-attribute %s.word\n", progname, corpus1_name);
    rcqp_receive_error(1);
  }
  if (NULL == (w2 = cl_new_attribute(corpus2, "word", ATT_POS))) {
   Rprintf( "%s: can't open p-attribute %s.word\n", progname, corpus2_name);
    rcqp_receive_error(1);
  }

  size1 = cl_max_cpos(w1);
  if (size1 <= 0) {
   Rprintf( "%s: data access error (%s.word)\n", progname, corpus1_name);
    rcqp_receive_error(1);
  }
  size2 = cl_max_cpos(w2);
  if (size2 <= 0) {
   Rprintf( "%s: data access error (%s.word)\n", progname, corpus2_name);
    rcqp_receive_error(1);
  }

  /* now work out the actual source corpus and the alignment attribute name (depending on -R flag) */
  source_corpus = (reverse) ? corpus2 : corpus1;
  source_corpus_name = (reverse) ? corpus2_name : corpus1_name;
  attribute_name = cl_strdup((reverse) ? corpus1_name : corpus2_name);
  cl_id_tolower(attribute_name); /* fold attribute name to lowercase */

  /* with -D option, determine data file name(s) from actual source corpus;
     otherwise use directory specified with -d and the usual naming conventions */
  if (data_dir_from_corpus) {
    Attribute *alignment = cl_new_attribute(source_corpus, attribute_name, ATT_ALIGN);
    char *comp_pathname;

    if (alignment == NULL) {
     Rprintf( "%s: alignment attribute %s.%s not declared in registry file\n",
              progname, source_corpus_name, attribute_name);
      rcqp_receive_error(1);
    }
    comp_pathname = component_full_name(alignment, CompXAlignData, NULL);
    if (comp_pathname == NULL) {
     Rprintf( "%s: can't determine pathname for .alx file (internal error)\n", progname);
      rcqp_receive_error(1);
    }
    strcpy(alx_name, comp_pathname); /* need to strcpy because component_full_name() returns pointer to internal buffer */
    if (compatibility) {
      comp_pathname = component_full_name(alignment, CompAlignData, NULL);
      if (comp_pathname == NULL) {
       Rprintf( "%s: can't determine pathname for .alg file (internal error)\n", progname);
        rcqp_receive_error(1);
      }
      strcpy(alg_name, comp_pathname);
    }
  }
  else {
    sprintf(alx_name, "%s" SUBDIR_SEP_STRING "%s.alx", data_dir, attribute_name);
    if (compatibility)
      sprintf(alg_name, "%s" SUBDIR_SEP_STRING "%s.alg", data_dir, attribute_name);
  }

  /* now open output file(s) */
  alx = fopen(alx_name, "wb");
  if (alx == NULL) {
    perror(alx_name);
   Rprintf( "%s: can't write file %s\n", progname, alx_name);
    rcqp_receive_error(1);
  }
  if (verbose)
   Rprintf("Writing file %s ...\n", alx_name);

  if (compatibility) {
    alg = fopen(alg_name, "wb");
    if (alg == NULL) {
      perror(alg_name);
     Rprintf( "%s: can't write file %s\n", progname, alg_name);
      rcqp_receive_error(1);
    }

    if (verbose)
     Rprintf("Writing file %s ...\n", alg_name);
  }

  /* main encoding loop */
  f1 = f2 = l1 = l2 = 0;
  mark = -1;                        /* check that regions occur in ascending order */
  current1 = current2 = -1;         /* for compatibility mode */
  n_0_1 = n_1_0 = 0;                /* number of 0:1 and 1:0 alignments, which are skipped */
  while (! feof(af)) {
    if (NULL == fgets(line, CL_MAX_LINE_LENGTH, af))
      break;                        /* end of file (or read error, which we choose to ignore) */
    if (4 != sscanf(line, "%d %d %d %d", &f1, &l1, &f2, &l2)) {
     Rprintf( "%s: input format error: %s", progname, line);
      rcqp_receive_error(1);
    }

    /* skip 0:1 and 1:0 alignments */
    if (l1 < f1) {
      n_0_1++; continue;
    }
    if (l2 < f2) {
      n_1_0++; continue;
    }

    /* check that source regions are non-overlapping and in ascending order */
    if (((reverse) ? f2 : f1) <= mark) {
     Rprintf( "%s: source regions of alignment must be in ascending order\n", progname);
     Rprintf( "Last region was [*, %d]; current is [%d, %d].\n", mark, f1, l1);
     Rprintf( "Aborted.\n");
      rcqp_receive_error(1);
    }
    mark = (reverse) ? l2 : l1;

    /* write alignment region to .alx file */
    if (reverse) {
      NwriteInt(f2, alx); NwriteInt(l2, alx);
      NwriteInt(f1, alx); NwriteInt(l1, alx);
    }
    else {
      NwriteInt(f1, alx); NwriteInt(l1, alx);
      NwriteInt(f2, alx); NwriteInt(l2, alx);
    }

    if (compatibility) {
      /* source and target regions of .alg file must be contiguous; store start points only; */
      /* hence we must collapse crossing alignments into one larger region (I know that's bullshit) */
      if ((f1 > current1) && (f2 > current2)) {
        if (reverse) {
          NwriteInt(f2, alg); NwriteInt(f1, alg);
        }
        else {
          NwriteInt(f1, alg); NwriteInt(f2, alg);
        }
        current1 = f1;
        current2 = f2;
      }
    }
  }
  if (compatibility) {
    if (reverse) {
      NwriteInt(size2, alg); NwriteInt(size1, alg); /* end of corpus alignment point*/
    }
    else {
      NwriteInt(size1, alg); NwriteInt(size2, alg); /* end of corpus alignment point*/
    }
  }

  if (verbose) {
   Rprintf("I skipped %d 0:1 alignments and %d 1:0 alignments.\n", n_0_1, n_1_0);
  }

  /* that's it; close file handles */
  fclose(alx);
  if (compatibility)
    fclose(alg);

  if (af_is_pipe)
    pclose(af);
  else
    fclose(af);

  return 0;
}
Beispiel #23
0
// to print in the R interface for GP models, for temporal beta
void GPsptp_para_printRnu (int i, int iteration, int report, int p, int u, double accept, 
     double *phi, double *nu, double *sig2e, double *sig2eta, double *sig2beta, 
     double *sig2delta, double *sig20, double *rho, double *beta) 
{
    int j, k;
    double phi1, nu1, sig2e1, sig2eta1, sig2beta1, sig2delta1, sig201, ii;
    phi1 = *phi;
    nu1 =*nu;
    sig2e1 = *sig2e;
    sig2eta1 = *sig2eta;
    sig2beta1 = *sig2beta;
    sig2delta1 = *sig2delta;    
    sig201 = *sig20;    

    double num =  (iteration/report); 
    int intpart = (int)num;

    for(j=0; j<report; j++){
    if(i==(intpart*(j+1)-1)){
      ii = (double) i;
      Rprintf("---------------------------------------------------------------\n");
      Rprintf(" Sampled: %i of %i, %3.2f%%.\n Batch Acceptance Rate (phi): %3.2f%%\n", 
      i+1, iteration, 100.0*(i+1)/iteration, 100.0*(accept/ii));
      Rprintf(" Checking Parameters: \n");
      Rprintf("   phi: %4.4f, nu: %4.4f, sig2eps: %4.4f, sig2eta: %4.4f,\n   sig2beta: %4.4f, sig2delta: %4.4f, sig2op: %4.4f,\n", 
      phi1, nu1, sig2e1, sig2eta1, sig2beta1, sig2delta1, sig201);
      for(k=0; k<u; k++){
      Rprintf("   rho[%d]: %4.4f", k+1, rho[k]);
      }
      Rprintf("\n");
      for(k=0; k<p; k++){
      Rprintf("   beta[%d]: %4.4f", k+1, beta[k]);
      }
      Rprintf("\n---------------------------------------------------------------\n");
      Rprintf(" ## Model used spatially and temporally varying dynamic parameters \n");
      Rprintf(" ## Spatial and dynamic beta parameters are omitted in the display ");
      Rprintf("\n---------------------------------------------------------------\n");
    }
    }
    return;
}
Beispiel #24
0
/**
 * Prints a message describing how to use the program to STDERR and then exits.
 */
void
alignencode_usage(void)
{
 Rprintf( "\n");
 Rprintf( "Usage: %s [options] <alignment_file>\n\n", progname);
 Rprintf( "\n");
 Rprintf( "Adds an alignment attribute to an existing CWB corpus\n");
 Rprintf( "\n");
 Rprintf( "Options:\n");
 Rprintf( "  -d <dir> write data file(s) to directory <dir>\n");
 Rprintf( "  -D       write files to corpus data directory\n");
 Rprintf( "  -C       compatibility mode (creates .alg file)\n");
  /*  Rprintf( "  -R       reverse alignment (target -> source)\n"); */
  /* -R option disabled ... need to re-order alignment file for reverse alignment */
 Rprintf( "  -r <reg> use registry directory <reg>\n");
 Rprintf( "  -v       verbose mode\n");
 Rprintf( "  -h       this help page\n\n");
 Rprintf( "Part of the IMS Open Corpus Workbench v" VERSION "\n\n");
  rcqp_receive_error(1);
}
Beispiel #25
0
/* print prefix */
static void pp(int pre) {
    /* this is sort of silly, I know, but it saves at least some output
       calls (and we can replace \t by spaces if desired) ... */
    while (pre >= 8) { Rprintf("\t"); pre -= 8; }
    while (pre-- > 0) Rprintf(" ");
}
Beispiel #26
0
/**
 * Parses the program's commandline arguments.
 *
 * Usage:
 *
 * optindex = alignencode_parse_args(argc, argv, required_arguments);
 *
 * @param ac        The program's argc
 * @param av        The program's argv
 * @param min_args  Minimum number of arguments to be parsed.
 * @return          The value of optind after parsing,
 *                  ie the index of the first argument in argv[]
 */
int
alignencode_parse_args(int ac, char *av[], int min_args)
{
  extern int optind;                  /* getopt() interface */
  extern char *optarg;                /* getopt() interface */
  int c;

  while ((c = getopt(ac, av, "hd:DCRr:v")) != EOF)
    switch (c) {
      /* -d: data directory */
    case 'd':
      if (data_dir == NULL)
        data_dir = optarg;
      else {
       Rprintf( "%s: -d option used twice\n", progname);
        rcqp_receive_error(2);
      }
      break;
      /* -D: use data directory of source corpus */
    case 'D':
      data_dir_from_corpus = 1;
      break;
      /* -C: compatibility mode */
    case 'C':
      compatibility = 1;
      break;
      /* -R: reverse alignment */
    case 'R':
      reverse = 1;
      break;
      /* -r: registry directory */
    case 'r':
      if (registry_dir == NULL)
        registry_dir = optarg;
      else {
       Rprintf( "%s: -r option used twice\n", progname);
        rcqp_receive_error(2);
      }
      break;
      /* -v: verbose */
    case 'v':
      verbose = 1;
      break;
      /* -h : help page = usage */
    case 'h':
      /* unknown option: print usage */
    default:
      alignencode_usage();
      break;
    }

  if (ac - optind != min_args)
    alignencode_usage();                /* no optional arguments in this case */

  if ((data_dir == NULL) && (! data_dir_from_corpus)) {
   Rprintf( "%s: either -d or -D must be specified\n", progname);
   Rprintf( "Type \"%s -h\" for more information.\n", progname);
    rcqp_receive_error(1);
  }

  if ((data_dir != NULL) && data_dir_from_corpus) {
   Rprintf( "%s: -d and -D flags cannot be used at the same time\n", progname);
   Rprintf( "Type \"%s -h\" for more information.\n", progname);
    rcqp_receive_error(1);
  }

  return(optind);                /* return index of first argument in argv[] */
}
Beispiel #27
0
/*
 * start the process of loading a sequence list file	
 */
bool msequenceServer::start(void)
{
	m_bStarted = false;
/*
 * return false if there are no more sequence list files	
 */
	if(m_dstrFasta.empty())	{
		return false;
	}
	m_strPath = m_dstrFasta.front();
	m_dstrFasta.pop_front();
	m_vstrPaths.push_back(m_strPath);
/*
 * open the file	
 */
	m_pInput = fopen(m_strPath.c_str(),"rb");
	if(m_pInput == NULL)	{
		m_bError = true;
		m_strStatus = "\n*********\nWarning:\n  Sequence list path '";
		m_strStatus += m_strPath;
		m_strStatus += "'\n  could not be opened and was skipped.\n*********\n\n";
//		cout << m_strStatus.c_str();
		Rprintf("%s", m_strStatus.c_str());
		return m_bStarted;
	}
	size_t tS = 0;
	char *pS = NULL;
	tS = fread(m_pLine,256,1,m_pInput);
	tS++; /* fool the compiler */

	string strDesc = "no description";
	if(strstr(m_pLine,"xbang-pro-fasta-format") != NULL)	{
		m_lFileType = XBANG;
		char *pV = m_pLine+64;
		if(strlen(pV) > 0)	{
			strDesc = pV;
		}
	}
	else if(m_pLine[0] == '>')	{
		fclose(m_pInput);
		m_lFileType = FASTA;
		m_pInput = fopen(m_strPath.c_str(),"r");
	}
	else	{
		m_lFileType = UNKNOWN;
		m_bError = true;
		m_strStatus = "\n*********\nWarning:\n  Sequence list path '";
		m_strStatus += m_strPath;
		m_strStatus += "'\n  was not in a recognized file format and was skipped.\n*********\n\n";
//		cout << m_strStatus.c_str();
		Rprintf("%s", m_strStatus.c_str());
		return m_bStarted;
	}
	m_vstrDesc.push_back(strDesc);
	m_bStarted = true;
	m_strStatus += "Path '";
	m_strStatus += m_strPath;
	m_strStatus += "' was opened.\n";
/*
 * read down to the first valid FASTA description line	
 */
	if(m_lFileType == XBANG)
		return m_bStarted;
	pS = fgets(m_pLine,m_lSize,m_pInput);
	while(m_pLine[0] != '>' && !feof(m_pInput))	{
		pS = fgets(m_pLine,m_lSize,m_pInput);
	}

	pS++; /* fool the compiler */

	if(m_pLine[0] == '>')	{
		char *pEol = NULL;
		if(strchr(m_pLine,0x01))	{
			pEol = strchr(m_pLine,0x01);
			*pEol = '\0';
		}
		else	{
			pEol = m_pLine + strlen(m_pLine) - 1;
			while(pEol > m_pLine && isspace(*pEol))	{
				*pEol = '\0';
				pEol--;
			}
		}
		pEol = strchr(m_pLine,'\r');
		if(pEol)	{
			*pEol = '\0';
		}
		pEol = strchr(m_pLine,'\n');
		if(pEol)	{
			*pEol = '\0';
		}
		m_strFirst = m_pLine+1;
	}
/*
 * create the msequencecollection object, if necessary	
 */
	return m_bStarted;
}
Beispiel #28
0
Datei: sizes.c Projekt: cran/eha
void strat_sizes(int *nn, double *enter, double *exit, int *event,
		 int *antrs, double *risktimes, 
		 int *n_events,int *size){
    /** nn = stratum size,
	enter[nn], exit[nn], event[nn] as usual
	antrs = No. of risksets in this stratum.
	risktimes[nn] (e.g. risksets[antrs])
	n.events[nn], size[nn] (eg [antrs] )!
    **/

    /* Data sorted ascending wrt exit, descending wrt event (for tied exit)

    */

    int i, start, nextstart;
    double th;

    for (i = 0; i < *nn; i++){
	n_events[i] = 0;
	size[i] = 0;
    }

    *antrs = 0;

    start = 0;

    while (start < *nn){
/* Reordered conditions in 2.2-3: */ 
	/* for (nextstart = start; (nextstart < *nn) & (event[nextstart] == 0); 
	   nextstart++); */
	nextstart = start;
	while (nextstart < *nn){
	    if (event[nextstart] == 1) break;
	    nextstart++;
	}
	if (nextstart >= *nn) return; /* Done in this stratum! */

	if (*antrs >= *nn) Rprintf("Error antrs in [sizes]\n");
	th = exit[nextstart];
	risktimes[*antrs] = th;
    
/* Reordered conditions in 2.2-3: */ 
	/* for (start = nextstart; (start < *nn) & (exit[start] == th) & 
	   (event[start] == 1); start++){ */
	start = nextstart;
	while (start < *nn){
	    if ((exit[start] == th) & (event[start] == 1)){
		n_events[*antrs]++;
		size[*antrs]++;
	    }else{
		break;
	    }
	    start++;
	}    
    
	for (i = start; i < *nn; i++){
	    if (enter[i] < th) size[*antrs]++;
	}
	(*antrs)++;
    }
}
Beispiel #29
0
/* 30   FORMAT(/10H   IT   NF,6X,1HF,7X,5HRELDF,3X,6HPRELDF,3X,5HRELDX,
   1       2X,13HMODEL  STPPAR) */
void F77_SUB(h30)(void)
{
    Rprintf("\n    IT   NF      F       RELDF   PRELDF   RELDX  MODEL  STPPAR\n");
}
Beispiel #30
0
SEXP read_png(SEXP sFn, SEXP sNative, SEXP sInfo) {
    SEXP res = R_NilValue, info_list = R_NilValue, info_tail = R_NilValue;
    const char *fn;
    char header[8];
    int native = asInteger(sNative), info = (asInteger(sInfo) == 1);
    FILE *f;
    read_job_t rj;
    png_structp png_ptr;
    png_infop info_ptr;
    
    if (TYPEOF(sFn) == RAWSXP) {
	rj.data = (char*) RAW(sFn);
	rj.len = LENGTH(sFn);
	rj.ptr = 0;
	rj.f = f = 0;
    } else {
	if (TYPEOF(sFn) != STRSXP || LENGTH(sFn) < 1) Rf_error("invalid filename");
	fn = CHAR(STRING_ELT(sFn, 0));
	f = fopen(fn, "rb");
	if (!f) Rf_error("unable to open %s", fn);
	if (fread(header, 1, 8, f) < 1 || png_sig_cmp((png_bytep) header, 0, 8)) {
	    fclose(f);
	    Rf_error("file is not in PNG format");
	}
	rj.f = f;
    }

    /* use our own error hanlding code and pass the fp so it can be closed on error */
    png_ptr = png_create_read_struct(PNG_LIBPNG_VER_STRING, (png_voidp)&rj, user_error_fn, user_warning_fn);
    if (!png_ptr) {
	if (f) fclose(f);
	Rf_error("unable to initialize libpng");
    }
    
    info_ptr = png_create_info_struct(png_ptr);
    if (!info_ptr) {
	if (f) fclose(f);
	png_destroy_read_struct(&png_ptr, (png_infopp)NULL, (png_infopp)NULL);
	Rf_error("unable to initialize libpng");
    }
    
    if (f) {
	png_init_io(png_ptr, f);
	png_set_sig_bytes(png_ptr, 8);
    } else
	png_set_read_fn(png_ptr, (png_voidp) &rj, user_read_data);

#define add_info(K, V) { info_tail = SETCDR(info_tail, CONS(V, R_NilValue)); SET_TAG(info_tail, install(K)); }

    /* png_read_png(png_ptr, info_ptr, PNG_TRANSFORM_STRIP_16 | PNG_TRANSFORM_EXPAND, NULL); */
    png_read_info(png_ptr, info_ptr);
    {
	png_uint_32 width, height;
	png_bytepp row_pointers;
	char *img_memory;
	SEXP dim;
	int bit_depth, color_type, interlace_type, compression_type, filter_method, rowbytes;
	int need_swap = 0;
	png_get_IHDR(png_ptr, info_ptr, &width, &height,
		     &bit_depth, &color_type, &interlace_type,
		     &compression_type, &filter_method);
	rowbytes = png_get_rowbytes(png_ptr, info_ptr);
#if VERBOSE_INFO
	Rprintf("png: %d x %d [%d], %d bytes, 0x%x, %d, %d\n", (int) width, (int) height, bit_depth, rowbytes,
		color_type, interlace_type, compression_type, filter_method);
#endif

	if (info) {
	    SEXP dv;
	    double d;
	    png_uint_32 rx, ry;
	    int ut, num_text = 0;
	    png_textp text_ptr;

	    info_tail = info_list = PROTECT(CONS((dv = allocVector(INTSXP, 2)), R_NilValue));
	    INTEGER(dv)[0] = (int) width;
	    INTEGER(dv)[1] = (int) height;
	    SET_TAG(info_list, install("dim"));
	    add_info("bit.depth", ScalarInteger(bit_depth));
	    switch(color_type) {
	    case PNG_COLOR_TYPE_GRAY: add_info("color.type", mkString("gray")); break;
	    case PNG_COLOR_TYPE_GRAY_ALPHA: add_info("color.type", mkString("gray + alpha")); break;
	    case PNG_COLOR_TYPE_PALETTE: add_info("color.type", mkString("palette")); break;
	    case PNG_COLOR_TYPE_RGB: add_info("color.type", mkString("RGB")); break;
	    case PNG_COLOR_TYPE_RGB_ALPHA: add_info("color.type", mkString("RGBA")); break;
	    default: add_info("color.type", ScalarInteger(color_type));
	    }
	    if (png_get_gAMA(png_ptr, info_ptr, &d)) add_info("gamma", ScalarReal(d));
#ifdef PNG_pHYs_SUPPORTED
	    if (png_get_pHYs(png_ptr, info_ptr, &rx, &ry, &ut)) {
		if (ut == PNG_RESOLUTION_METER) {
		    dv = allocVector(REALSXP, 2);
		    REAL(dv)[0] = ((double)rx) / 39.37008;
		    REAL(dv)[1] = ((double)ry) / 39.37008;
		    add_info("dpi", dv);
		} else if (ut == PNG_RESOLUTION_UNKNOWN)
		    add_info("asp", ScalarReal(rx / ry));
	    }
	    if (png_get_text(png_ptr, info_ptr, &text_ptr, &num_text)) {
		SEXP txt_key, txt_val = PROTECT(allocVector(STRSXP, num_text));
		if (num_text) {
		    int i;
		    setAttrib(txt_val, R_NamesSymbol, txt_key = allocVector(STRSXP, num_text));
		    for (i = 0; i < num_text; i++) {
			SET_STRING_ELT(txt_val, i, text_ptr[i].text ? mkChar(text_ptr[i].text) : NA_STRING);
			SET_STRING_ELT(txt_key, i, text_ptr[i].key ? mkChar(text_ptr[i].key) : NA_STRING);
		    }
		}
		add_info("text", txt_val);
		UNPROTECT(1);
	    }
#endif
	}

	/* on little-endian machines it's all well, but on big-endian ones we'll have to swap */
#if ! defined (__BIG_ENDIAN__) && ! defined (__LITTLE_ENDIAN__)   /* old compiler so have to use run-time check */
	{
	    char bo[4] = { 1, 0, 0, 0 };
	    int bi;
	    memcpy(&bi, bo, 4);
	    if (bi != 1)
		need_swap = 1;
	}
#endif
#ifdef __BIG_ENDIAN__
	need_swap = 1;
#endif

	/*==== set any transforms that we desire: ====*/
	/* palette->RGB - no discussion there */
	if (color_type == PNG_COLOR_TYPE_PALETTE)
	    png_set_palette_to_rgb(png_ptr);
	/* expand gray scale to 8 bits */
	if (color_type == PNG_COLOR_TYPE_GRAY &&
	    bit_depth < 8) png_set_expand_gray_1_2_4_to_8(png_ptr);
	/* this should not be necessary but it's in the docs to guarantee 8-bit */
	if (bit_depth < 8)
	    png_set_packing(png_ptr);
	/* convert tRNS chunk into alpha */
	if (png_get_valid(png_ptr, info_ptr, PNG_INFO_tRNS))
	    png_set_tRNS_to_alpha(png_ptr);
	/* native format doesn't allow for 16-bit so it needs to be truncated */
	if (bit_depth == 16 && native) {
	    Rf_warning("Image uses 16-bit channels but R native format only supports 8-bit, truncating LSB."); 
	    png_set_strip_16(png_ptr);
	}
	/* for native output we need to a) convert gray to RGB, b) add alpha */
	if (native) {
	    if (color_type == PNG_COLOR_TYPE_GRAY || color_type == PNG_COLOR_TYPE_GRAY_ALPHA)
		png_set_gray_to_rgb(png_ptr);
	    if (!(color_type & PNG_COLOR_MASK_ALPHA)) /* if there is no alpha, add it */
		png_set_add_alpha(png_ptr, 0xFF, PNG_FILLER_AFTER);
	}
#if 0 /* we use native (network) endianness since we read each byte anyway */
	/* on little-endian machines we need to swap 16-bit values - this is the inverse of need_swap as used for R! */
	if (!need_swap && bit_depth == 16)
	    png_set_swap(png_ptr);
#endif

	/* PNG wants up to call png_set_interlace_handling so it can get ready to de-interlace images */
	png_set_interlace_handling(png_ptr);

	/* all transformations are in place, so it's time to update the info structure so we can allocate stuff */
	png_read_update_info(png_ptr, info_ptr);

	/* re-read some important bits from the updated structure */
	rowbytes = png_get_rowbytes(png_ptr, info_ptr);
	bit_depth = png_get_bit_depth(png_ptr, info_ptr);
	color_type = png_get_color_type(png_ptr, info_ptr);

#if VERBOSE_INFO
	Rprintf("   -filter-> %d-bits, %d bytes, 0x%x\n", bit_depth, rowbytes, color_type);
#endif

	/* allocate data fro row pointers and the image using R's allocation */
	row_pointers = (png_bytepp) R_alloc(height, sizeof(png_bytep));
	img_memory = R_alloc(height, rowbytes);
	{ /* populate the row pointers */
	    char *i_ptr = img_memory;
	    int i;
	    for (i = 0; i < height; i++, i_ptr += rowbytes)
	      row_pointers[i] = (png_bytep) i_ptr;
	}
	
	/* do the reading work */
	png_read_image(png_ptr, row_pointers);
	
	if (f) {
	    rj.f = 0;
	    fclose(f);
	}

	/* native output - vector of integers */
	if (native) {
	    int pln = rowbytes / width;
	    if (pln < 1 || pln > 4) {
		png_destroy_read_struct(&png_ptr, &info_ptr, (png_infopp)NULL);
		Rf_error("native output for %d planes is not possible.", pln);
	    }

	    res = PROTECT(allocVector(INTSXP, width * height));
	    if (pln == 4) { /* 4 planes - efficient - just copy it all */
		int y, *idata = INTEGER(res);
		for (y = 0; y < height; idata += width, y++)
		    memcpy(idata, row_pointers[y], width * sizeof(int));

		if (need_swap) {
		    int *ide = idata;
		    idata = INTEGER(res);
		    for (; idata < ide; idata++)
			RX_swap32(*idata);
		}
	    } else if (pln == 3) { /* RGB */
		int x, y, *idata = INTEGER(res);
		for (y = 0; y < height; y++)
		    for (x = 0; x < rowbytes; x += 3)
			*(idata++) = R_RGB((unsigned int) row_pointers[y][x],
					   (unsigned int) row_pointers[y][x + 1],
					   (unsigned int) row_pointers[y][x + 2]);
	    } else if (pln == 2) { /* GA */
		int x, y, *idata = INTEGER(res);
		for (y = 0; y < height; y++)
		    for (x = 0; x < rowbytes; x += 2)
			*(idata++) = R_RGBA((unsigned int) row_pointers[y][x],
					    (unsigned int) row_pointers[y][x],
					    (unsigned int) row_pointers[y][x],
					    (unsigned int) row_pointers[y][x + 1]);
	    } else { /* gray */
		int x, y, *idata = INTEGER(res);
		for (y = 0; y < height; y++)
		    for (x = 0; x < rowbytes; x++)
			*(idata++) = R_RGB((unsigned int) row_pointers[y][x],
					   (unsigned int) row_pointers[y][x],
					   (unsigned int) row_pointers[y][x]);
	    }
	    dim = allocVector(INTSXP, 2);
	    INTEGER(dim)[0] = height;
	    INTEGER(dim)[1] = width;
	    setAttrib(res, R_DimSymbol, dim);
	    setAttrib(res, R_ClassSymbol, mkString("nativeRaster"));
	    setAttrib(res, install("channels"), ScalarInteger(pln));
	    UNPROTECT(1);
	} else {
	    int x, y, p, pln = rowbytes / width, pls = width * height;
	    double * data;
	    if (bit_depth == 16) {
		res = PROTECT(allocVector(REALSXP, (rowbytes * height) / 2));
		pln /= 2;
	    } else
		res = PROTECT(allocVector(REALSXP, rowbytes * height));

	    data = REAL(res);
	    if (bit_depth == 16)
		for(y = 0; y < height; y++)
		    for (x = 0; x < width; x++)
			for (p = 0; p < pln; p++)
			    data[y + x * height + p * pls] = ((double)(
								       (((unsigned int)(((unsigned char *)row_pointers[y])[2 * (x * pln + p)])) << 8) |
								        ((unsigned int)(((unsigned char *)row_pointers[y])[2 * (x * pln + p) + 1]))
								       )) / 65535.0;
	    else 
		for(y = 0; y < height; y++)
		    for (x = 0; x < width; x++)
			for (p = 0; p < pln; p++)
			    data[y + x * height + p * pls] = ((double)row_pointers[y][x * pln + p]) / 255.0;
	    dim = allocVector(INTSXP, (pln > 1) ? 3 : 2);
	    INTEGER(dim)[0] = height;
	    INTEGER(dim)[1] = width;
	    if (pln > 1)
		INTEGER(dim)[2] = pln;
	    setAttrib(res, R_DimSymbol, dim);
	    UNPROTECT(1);
	}
    }

    if (info) {
	PROTECT(res);
	setAttrib(res, install("info"), info_list);
	UNPROTECT(2);
    }
    
    png_destroy_read_struct(&png_ptr, &info_ptr, (png_infopp)NULL);

    return res;
}