double lcgf(double a, double x) {
int i;
const double EPS=std::numeric_limits<double>::epsilon();
const double FPMIN=std::numeric_limits<double>::min()/EPS;
double an,b,c,d,del,h,gln=gammln(a);
// assert(x>=(a+1));
BOINCASSERT(x>=(a+1));
b=x+1.0-a;
c=1.0f/FPMIN;
d=1.0/b;
h=d;
for (i=1;i<=ITMAX;i++) {
an = -i*(i-a);
b += 2.0;
d=an*d+b;
if (fabs(d)<FPMIN) d=FPMIN;
c=b+an/c;
if (fabs(c)<FPMIN) c=FPMIN;
d=1.0/d;
del=d*c;
h*=del;
if (fabs(del-1.0)<EPS) break;
}
// assert(i<ITMAX);
BOINCASSERT(i<ITMAX);
return (float)(log(h)-x+a*log(x)-gln);
}
int gser(double *gamser, double a, double x, double *gln)
{
double gammln(double xx);
int n;
double sum,del,ap;
*gln=gammln(a);
if (x <= 0.0) {
if (x < 0.0) {
fprintf ( stderr, "x less than 0 in routine gser\n");
return 1;
}
*gamser=0.0;
return 0;
} else {
ap=a;
del=sum=1.0/a;
for (n=1;n<=ITMAX;n++) {
++ap;
del *= x/ap;
sum += del;
if (fabs(del) < fabs(sum)*EPS) {
*gamser=sum*exp(-x+a*log(x)-(*gln));
return 0;
}
}
fprintf( stderr, "a too large, ITMAX too small in routine gser\n");
return 1;
}
}
void Statistics::gser(double *gamser, double a, double x, double *gln)
{
int n;
double sum, del, ap;
*gln = gammln(a);
if(x <= 0.0){
*gamser=0.0;
return;
}
else
{
ap = a;
del = sum = 1.0/a;
for(n = 1; n <= Statistics::ITMAX(); n++){
ap += 1.0;
del *= x/ap;
sum += del;
if(fabs(del) < fabs(sum)*Statistics::EPS()){
*gamser=sum*exp(-x+a*log(x)-(*gln));
return;
}
}
throw GammaFxnFailureException();
return;
}
}
void Statistics::gcf(double *gammcf, double a, double x, double *gln)
{
int n;
double gold = 0.0, g, fac = 1.0, b1 = 1.0;
double b0= 0.0, anf, ana, an, a1, a0 = 1.0;
*gln = gammln(a);
a1 = x;
for(n = 1 ; n <= Statistics::ITMAX() ; n++){
an = static_cast<double>(n);
ana = an - a;
a0 = (a1 + a0 * ana) * fac;
b0 = (b1 + b0 * ana) * fac;
anf = an * fac;
a1 = x * a0 + anf * a1;
b1 = x * b0 + anf * b1;
if(a1 > pow(Statistics::EPS(),3)){ // CHANGED BY RTG to avoid f.p. compare.
fac = 1.0/a1;
g= b1 * fac;
if(fabs((g - gold)/g) < Statistics::EPS()){
*gammcf = exp(-x + a * log(x) - (*gln)) * g;
return;
}
gold = g;
}
}
throw GammaFxnFailureException();
}
void Test::gcf(float *gammcf, float a, float x, float *gln)
{
int i;
float an, b, c, d, del, h;
*gln = gammln(a);
b = x + 1.0 - a;
c = 1.0/FPMIN;
d = 1.0/b;
h = d;
for(i = 1; i <= ITMAX; i++) //iterate to convergence
{
an = -i*(i - a);
b += 2.0; //Set up for evaluating continued
d = an*d + b; //fraction by modified Lentz's method with b_0 = 0.
if(fabs(d) < FPMIN)
d = FPMIN;
c = b + an/c;
if(fabs(c) < FPMIN)
c = FPMIN;
d = 1.0/d;
del = d*c;
h *= del;
if(fabs(del - 1.0) < EPS)
break;
}
if (i > ITMAX)
nerror("a too large, ITMAX too small in continued fraction gamma function");
*gammcf = exp(-x + a*log(x) - (*gln))*h; //Put factors in front
return;
}
void gcf(float *gammcf, float a, float x, float *gln)
{
int i;
float an,b,c,d,del,h;
*gln=gammln(a);
b=x+1.0-a;
c=1.0/FPMIN;
d=1.0/b;
h=d;
for (i=1;i<=ITMAX;i++) {
an = -i*(i-a);
b += 2.0;
d=an*d+b;
if (fabs(d) < FPMIN) d=FPMIN;
c=b+an/c;
if (fabs(c) < FPMIN) c=FPMIN;
d=1.0/d;
del=d*c;
h *= del;
if (fabs(del-1.0) < EPS) break;
}
if (i > ITMAX) nrerror("a too large, ITMAX too small in gcf");
*gammcf=exp(-x+a*log(x)-(*gln))*h;
}
//gser --- Returns the incomplete gamma function P(a,x)
//evaluated by its series representation. Also returns
//natural log of gamma(a)
void Test::gser(float *gamser, float a, float x, float *gln)
{
int n;
float sum, del, ap;
*gln = gammln(a);
if(x <= 0.0)
{
if(x < 0.0)
nerror("x less than zero in series expansion gamma function");
*gamser = 0.0;
return;
}
else
{
ap = a;
del = sum = 1.0/a;
for(n = 1; n <= ITMAX; n++)
{
++ap;
del *= x/ap;
sum += del;
if(fabs(del) < (fabs(sum)*EPS))
{
*gamser = sum*exp(-x + (a*log(x)) - (*gln));
return;
}
}
nerror("a is too large, ITMAX is too small, in series expansion gamma function");
return;
}
}
float gammln(float xx)
{
double x,y,tmp,ser,sinus;
static double cof[6]={76.18009172947146,-86.50532032941677,
24.01409824083091,-1.231739572450155,
0.1208650973866179e-2,-0.5395239384953e-5};
int j;
/* Different Cases */
nr_gamm_sign = 1;
if (xx <= 0)
{
sinus = sin(M_PI*xx);
if (sinus == 0.)
nrerror("The gamma function is not defined for <= integers");
tmp = log(M_PI) - gammln(1.-xx) - log(fabs(sinus));
if (sinus < 0)
nr_gamm_sign = -1;
return (float) tmp;
}
y=x=xx;
tmp=x+5.5;
tmp -= (x+0.5)*log(tmp);
ser=1.000000000190015;
for (j=0;j<=5;j++) ser += cof[j]/++y;
return -tmp+log(2.5066282746310005*ser/x);
}
void gser(float *gamser, float a, float x, float *gln)
{
int n;
float sum,del,ap;
*gln=gammln(a);
if (x <= 0.0) {
if (x < 0.0) nrerror("x less than 0 in routine gser");
*gamser=0.0;
return;
} else {
ap=a;
del=sum=1.0/a;
for (n=1;n<=ITMAX;n++) {
++ap;
del *= x/ap;
sum += del;
if (fabs(del) < fabs(sum)*EPS) {
*gamser=sum*exp(-x+a*log(x)-(*gln));
return;
}
}
nrerror("a too large, ITMAX too small in routine gser");
return;
}
}
void _poidev(float *xmv, long n)
/* all floats -> doubles on June 2010 to avoid SIGFPE
for too large input values */
{
double gammln(double xx);
/* float ran1(long *idum);*/
static double sq,alxm,g,oldm=(-1.0);
double xm,em,t,y,y1;
long i;
for (i=0;i<n;i++) {
xm = (double)xmv[i];
if (xm == 0.0f) continue;
if (xm < 20.0) { /* Use direct method. */
if (xm != oldm) {
oldm=xm;
g=exp(-xm); /* If xm is new, compute the exponential. */
}
em = -1;
t=1.0;
do {
++em;
t *= ran1();
} while (t > g);
} else { /* Use rejection method. */
if (xm != oldm) {
oldm=xm;
sq=sqrt(2.0*xm);
alxm=log(xm);
// printf("xm+1.0 = %.f gammln(xm+1.0) = %.f\n",xm+1.0,gammln(xm+1.0));
g=xm*alxm-gammln(xm+1.0);
}
do {
do {
y=tan(3.1415926535897932384626433832*ran1());
em=sq*y+xm;
} while (em < 0.0);
em=floor(em);
// printf("em+1.0 = %.f gammln(em+1.0) = %.f\n",em+1.0,gammln(em+1.0));
// printf("exp(em*alxm-gammln(em+1.0)-g) = %.f\n",exp(em*alxm-gammln(em+1.0)-g));
t=0.9*(1.0+y*y)*exp(em*alxm-gammln(em+1.0)-g);
} while (ran1() > t);
}
xmv[i] = (float)em;
}
}
/*************************************************************************************************************
Procedure: bico
From Numerical Recipes: calculates binomial coefficients
************************************************************************************************************/
float bico(int n, int k)
{
float lnfactn, lnfactk, lnfactnk, bin;
if (k > n) bin = 0.0;
else if (k < 0) bin = 0.0;
else if (k == 0) bin = 1.0;
else
{
lnfactn = gammln((float)(n+1));
lnfactk = gammln((float)(k+1));
lnfactnk = gammln((float)(n-k+1));
bin = floor(0.5+exp(lnfactn - lnfactk - lnfactnk));
}
return (bin);
}
/* Incomplete beta function
* ------------------------
* Numerical Recipes pg 227
*/
REAL_TYPE betai(REAL_TYPE a, REAL_TYPE b, REAL_TYPE x) throw(std::invalid_argument)
{
REAL_TYPE bt;
if(x<0.00||x>1.00) throw(std::invalid_argument(std::string("betai():x must be between 0.0 and 1.0")));
if(x==0.0 || x==1.0) bt=0.0;
else bt=std::exp(gammln(a+b)-gammln(a)-gammln(b)+a*std::log(x)+b*std::log(1.0-x));
if(x< (a+1.0)/(a+b+2.0))
{
return (bt*betacf(a,b,x)/a);
}
else
{
return(1.0-bt*betacf(b,a,1.0-x)/b);
}
}
bool_t getBarklemcross(Barklemstruct *bs, RLK_Line *rlk)
{
const char routineName[] = "getBarklemcross";
int index;
double Z, neff1, neff2, findex1, findex2, reducedmass, meanvelocity,
crossmean, E_Rydberg, deltaEi, deltaEj;
Element *element;
element = &atmos.elements[rlk->pt_index - 1];
/* --- Note: ABO tabulations are valid only for neutral atoms -- -- */
if (rlk->stage > 0)
return FALSE;
if ((deltaEi = element->ionpot[rlk->stage] - rlk->Ei) <= 0.0)
return FALSE;
if ((deltaEj = element->ionpot[rlk->stage] - rlk->Ej) <= 0.0)
return FALSE;
Z = (double) (rlk->stage + 1);
E_Rydberg = E_RYDBERG / (1.0 + M_ELECTRON / (element->weight * AMU));
neff1 = Z * sqrt(E_Rydberg / deltaEi);
neff2 = Z * sqrt(E_Rydberg / deltaEj);
if (rlk->Li > rlk->Lj) SWAPDOUBLE(neff1, neff2);
if (neff1 < bs->neff1[0] || neff1 > bs->neff1[bs->N1-1])
return FALSE;
Locate(bs->N1, bs->neff1, neff1, &index);
findex1 =
(double) index + (neff1 - bs->neff1[index]) / BARKLEM_DELTA_NEFF;
if (neff2 < bs->neff2[0] || neff2 > bs->neff2[bs->N2-1])
return FALSE;
Locate(bs->N2, bs->neff2, neff2, &index);
findex2 =
(double) index + (neff2 - bs->neff2[index]) / BARKLEM_DELTA_NEFF;
/* --- Find interpolation in table -- -------------- */
rlk->cross = cubeconvol(bs->N2, bs->N1,
bs->cross[0], findex2, findex1);
rlk->alpha = cubeconvol(bs->N2, bs->N1,
bs->alpha[0], findex2, findex1);
reducedmass = AMU / (1.0/atmos.H->weight + 1.0/element->weight);
meanvelocity = sqrt(8.0 * KBOLTZMANN / (PI * reducedmass));
crossmean = SQ(RBOHR) * pow(meanvelocity / 1.0E4, -rlk->alpha);
rlk->cross *= 2.0 * pow(4.0/PI, rlk->alpha/2.0) *
exp(gammln((4.0 - rlk->alpha)/2.0)) * meanvelocity * crossmean;
rlk->vdwaals = BARKLEM;
return TRUE;
}
int bnlrnd(double pp, int n)
{
int j;
static int nold=(-1);
double am,em,g,angle,p,bnl,sq,t,y;
static double pold=(-1.0),pc,plog,pclog,en,oldg;
p=(pp <= 0.5 ? pp : 1.0-pp);
am=n*p; //This is the mean of the deviate to be produced.
if (n < 25) {
bnl = 0.0;
for (j=1;j<=n;j++)
if (ran2() < p) ++bnl;
} else if (am < 1.0) {
g=exp(-am);
t=1.0;
for (j=0;j<=n;j++) {
t *= ran2();
if (t < g) break;
}
bnl=(j <= n ? j : n);
} else {
if (n != nold) {
en=n;
oldg=gammln(en+1.0);
nold=n;
} if (p != pold) {
pc=1.0-p;
plog=log(p);
pclog=log(pc);
pold=p;
}
sq=sqrt(2.0*am*pc);
do {
do {
angle=PI*ran2();
y=tan(angle);
em=sq*y+am;
} while (em < 0.0 || em >= (en+1.0));
em=floor(em);
t=1.2*sq*(1.0+y*y)*exp(oldg-gammln(em+1.0)-gammln(en-em+1.0)+em*plog+(en-em)*pclog);
} while (ran2() > t); bnl=em;
}
if (p != pp) bnl=n-bnl;
return (int)bnl;
}
dvariable dgamma(const prevariable& x, const double& a, const double& b)
{
//returns the gamma density with a & b as parameters
RETURN_ARRAYS_INCREMENT();
dvariable t1 = 1./(pow(b,a)*mfexp(gammln(a)));
dvariable t2 = (a-1.)*log(x)-x/b;
RETURN_ARRAYS_DECREMENT();
return(t1*mfexp(t2));
}
// Returns the density of a gamma pdf at x
double log_gamma_pdf(double alpha, double beta, double x)
{
if (x < 0)
return 0;
double out;
out = (alpha - 1.0) * log(x) - alpha*log(beta) - gammln(alpha) - (x / beta);
return out;
}
//Input: alf = the alpha parameter of the Laguerre polynomials
// pointsNum = the polynom order
//Output: the abscissas and weights are stored in the vecotrs x and w, respectively.
//Discreption: given alf, the alpha parameter of the Laguerre polynomials, the function returns the abscissas and weights
// of the n-point Guass-Laguerre quadrature formula.
// The smallest abscissa is stored in x[0], the largest in x[pointsNum - 1].
void GLaguer::gaulag(Vdouble &x, Vdouble &w, const MDOUBLE alf, const int pointsNum)
{
x.resize(pointsNum, 0.0);
w.resize(pointsNum, 0.0);
const int MAXIT=10000;
const MDOUBLE EPS=1.0e-6;
int i,its,j;
MDOUBLE ai,p1,p2,p3,pp,z=0.0,z1;
int n= x.size();
for (i=0;i<n;i++) {
//loops over the desired roots
if (i == 0) { //initial guess for the smallest root
z=(1.0+alf)*(3.0+0.92*alf)/(1.0+2.4*n+1.8*alf);
} else if (i == 1) {//initial guess for the second smallest root
z += (15.0+6.25*alf)/(1.0+0.9*alf+2.5*n);
} else { //initial guess for the other roots
ai=i-1;
z += ((1.0+2.55*ai)/(1.9*ai)+1.26*ai*alf/
(1.0+3.5*ai))*(z-x[i-2])/(1.0+0.3*alf);
}
for (its=0;its<MAXIT;its++) { //refinement by Newton's method
p1=1.0;
p2=0.0;
for (j=0;j<n;j++) { //Loop up the recurrence relation to get the Laguerre polynomial evaluated at z.
p3=p2;
p2=p1;
p1=((2*j+1+alf-z)*p2-(j+alf)*p3)/(j+1);
}
//p1 is now the desired Laguerre polynomial. We next compute pp, its derivative,
//by a standard relation involving also p2, the polynomial of one lower order.
pp=(n*p1-(n+alf)*p2)/z;
z1=z;
z=z1-p1/pp; //Newton's formula
if (fabs(z-z1) <= EPS)
break;
}
if (its >= MAXIT)
errorMsg::reportError("too many iterations in gaulag");
x[i]=z;
w[i] = -exp(gammln(alf+n)-gammln(MDOUBLE(n)))/(pp*n*p2);
}
}
/*
poisson deviate, from numerical recipes in C pp. 294ff
*/
double poidev(double mean)
{
double gammln(double xx);
static double sq, alxm, g, oldm=(-1.0);
double em, t, y;
if (mean < 12.0)
{
if (mean != oldm)
{
oldm = mean;
g=exp(-mean);
}
em = -1;
t=1.0;
do
{
++em;
t *= unif_distn();
} while (t > g);
}
else
{
if (mean != oldm)
{
oldm=mean;
sq=sqrt(2.0*mean);
alxm=log(mean);
g=mean*alxm-gammln(mean+1.0);
}
do
{
do
{
y = tan(M_PI*unif_distn());
em = sq*y+mean;
} while (em < 0.0);
em = floor(em);
t=0.9 * (1.0 + y*y) * exp(em*alxm-gammln(em+1.0)-g);
} while (unif_distn() > t);
}
return em;
}
int main(void)
{
double gam1,gam2,gampl,gammi,x,xgam1,xgam2,xgampl,xgammi;
for (;;) {
printf("Enter x:\n");
if (scanf("%lf",&x) == EOF) break;
beschb(x,&xgam1,&xgam2,&xgampl,&xgammi);
printf("%5s\n%17s %16s %17s %15s\n%17s %16s %17s %15s\n",
"x","gam1","gam2","gampl","gammi","xgam1","xgam2","xgampl","xgammi");
gampl=1/exp(gammln((float)(1+x)));
gammi=1/exp(gammln((float)(1-x)));
gam1=(gammi-gampl)/(2*x);
gam2=(gammi+gampl)/2;
printf("%5.2f\n\t%16.6e %16.6e %16.6e %16.6e\n",x,gam1,gam2,gampl,gammi);
printf("\t%16.6e %16.6e %16.6e %16.6e\n",xgam1,xgam2,xgampl,xgammi);
}
return 0;
}
double bkgd_t_dist_gamma(double t, void *v) {
BkgdParam *p = v;
double k = p->gamma_shape;
double m = p->gamma_scale;
double tgamma;
tgamma = exp(gammln(k));
return (p->gamma_c * pow(t, k-1.0) * exp(-t/m)) / (tgamma * pow(m,k));
}
// Returns a factorial
double factorial(int n)
{
static int ntop=4;
static double a[33]={1.0,1.0,2.0,6.0,24.0};
int j;
if (n < 0) nrerror("Negative factorial in routine factrl");
if (n > 32) return exp(gammln(n+1.0));
while (ntop<n) {
j=ntop++;
a[ntop]=a[j]*ntop;
}
return a[n];
}
df1b2variable log_negbinomial_density(double x,const df1b2variable& _xmu,
const df1b2variable& _xtau)
{
ADUNCONST(df1b2variable,xmu)
ADUNCONST(df1b2variable,xtau)
init_df3_two_variable mu(xmu);
init_df3_two_variable tau(xtau);
*mu.get_u_x()=1.0;
*tau.get_u_y()=1.0;
if (value(tau)-1.0<0.0)
{
cerr << "tau <=1 in log_negbinomial_density " << endl;
ad_exit(1);
}
df3_two_variable r=mu/(1.e-120+(tau-1.0));
df3_two_variable tmp;
tmp=gammln(x+r)-gammln(r) -gammln(x+1)
+r*log(r)+x*log(mu)-(r+x)*log(r+mu);
df1b2variable tmp1;
tmp1=tmp;
return tmp1;
}
/* Returns the incomplete beta function Ix (a, b). */
double betai(double a, double b, double x)
{ double gammln(double xx);
double bt;
if (x < 0.0 || x > 1.0){
fprintf( StdErr, "Bad x==%s in routine betai\n", d2str(x, NULL, NULL) );
}
if( x== 0.0 || x== 1.0 ){
bt=0.0;
}
else{
/* Factors in front of the continued fraction. */
bt= exp( gammln(a+b)- gammln(a)- gammln(b)+ a* log(x)+ b* log(1.0-x) );
}
if( x< (a+1.0)/(a+b+2.0) ){
/* Use continued fraction directly. */
return( bt* betacf(a,b,x)/ a );
}
else{
/* Use continued fraction after making the symmetry transformation. */
return( 1.0- bt* betacf( b,a,1.0-x )/ b );
}
}
int sample_lambda_prior_COST(Data_COST *i_D_COST)
{
int i,h,T,num;
double sumLambda,sumLogLambda;
double c_new,c_old,log_new,log_old,accProb,u;
double e = 0.001;
double f = 0.001;
double fac = 0.01;
sumLambda = G_ZERO;
sumLogLambda = G_ZERO;
for(h=0;h<i_D_COST->mland->n_trip;h++)
{
sumLambda += i_D_COST->mland->lambda[h];
sumLogLambda += log(i_D_COST->mland->lambda[h]);
}
T = i_D_COST->mland->n_trip;
num=1000;
c_old = i_D_COST->mland->c;
for(i=0;i<num;i++)
{
c_new = scale_proposal(c_old,fac,NULL);
log_new = -T*log(exp(gammln(c_new))) + (c_new-1)*sumLogLambda
+log(exp(gammln(e+c_new*T))) - (e+c_new*T)*log(f+sumLambda);
log_old = -T*log(exp(gammln(c_old))) + (c_old-1)*sumLogLambda
+log(exp(gammln(e+c_old*T))) - (e+c_old*T)*log(f+sumLambda);
accProb = log_new - log_old;
u = genunf(G_ZERO,G_ONE);
if(accProb > -1.0e32 && accProb < 1.0e32 && log(u) < accProb)
c_old = c_new;
}
i_D_COST->mland->c = c_old;
i_D_COST->mland->d = gengam(f+sumLambda,e+i_D_COST->mland->c*T);
return(0);
} /* end of sample_lambda_prior_COST */
double logddirichlet(double *x,double *alpha,int len)
{
//logD <- sum(lgamma(alpha)) - lgamma(sum(alpha))
//s <- sum((alpha - 1) * log(x))
//sum(s) - logD)
// This function calculates the log dirichlet density
double logD=0.0,logdens,sumalpha=0.0,s=0.0;
int k;
for(k=0;k<len;k++) {
s += (alpha[k]-1)*log(x[k]);
sumalpha += alpha[k];
logD += gammln(alpha[k]);
}
logD -= gammln(sumalpha);
logdens = s-logD;
return(logdens);
}
double factrl(int n){
//void nrerror(char error_text[]);
static int ntop = 4;
static double a[33] = {1.0, 1.0, 2.0, 6.0, 24.0};
int j;
if (n < 0) printf("Negative factorial in routine factrl");
if (n > 32) return (exp(gammln(n + 1.0)));
while (ntop < n){
j = ntop++;
a[ntop] = a[j]*ntop;
}
return(a[n]);
}
/**
\author Steven James Dean Martell UBC Fisheries Centre
\date 2011-06-24
\param k vector of observed numbers
\param lambda vector of epected means of the distribution
\return returns the negative loglikelihood \f$\sum_i -k_i \ln( \lambda_i ) - \lambda_i + \ln(k_i!) \f$
\sa
**/
dvariable dpois(const dvector& k, const dvar_vector& lambda)
{
RETURN_ARRAYS_INCREMENT();
int i;
int n = size_count(k);
dvariable nll=0;
for(i = 1; i <= n; i++)
{
// nll -= k(i)*log(lambda(i))+lambda(i)+gammln(k(i)+1.);
nll += -k(i)*log(lambda(i))+lambda(i)+gammln(k(i)+1.);
}
RETURN_ARRAYS_DECREMENT();
return nll;
}
/* function: factrl(int n)
* ------------------------
* Numerical Recipes p. 214
*/
REAL_TYPE factrl(int n)
{
static int ntop=4;
static REAL_TYPE a[33]={1.0,1.0,2.0,6.0,24.0};
int j;
if(n<0) throw std::invalid_argument("negative factorial in routine factrl");
if(n>32) return std::exp(gammln(n+1.0));
while(ntop<n)
{
j=ntop++;
a[ntop]=a[j]*ntop;
}
return a[n];
}
dvariable mult_likelihood(const dmatrix &o, const dvar_matrix &p, dvar_matrix &nu,
const dvariable &log_vn)
{
// kludge to ensure observed and predicted matrixes are the same size
if(o.colsize()!=p.colsize() || o.rowsize()!=p.rowsize())
{
cerr<<"Error in multivariate_t_likelihood, observed and predicted matrixes"
" are not the same size\n";
ad_exit(1);
}
dvariable vn = mfexp(log_vn);
dvariable ff = 0.0;
int r1 = o.rowmin();
int r2 = o.rowmax();
int c1 = o.colmin();
int c2 = o.colmax();
for(int i = r1; i <= r2; i++ )
{
dvar_vector sobs = vn * o(i)/sum(o(i)); //scale observed numbers by effective sample size.
ff -= gammln(vn);
for(int j = c1; j <= c2; j++ )
{
if( value(sobs(j)) > 0.0 )
ff += gammln(sobs(j));
}
ff -= sobs * log(TINY + p(i));
dvar_vector o1=o(i)/sum(o(i));
dvar_vector p1=p(i)/sum(p(i));
nu(i) = elem_div(o1-p1,sqrt(elem_prod(p1,1.-p1)/vn));
}
// exit(1);
return ff;
}
/*
*----------------------------------------------------------------
* Returns as a floating point number an integer value that is
* a random deviate drawn from a Poisson distribution of mean
* "xm", using ran1(idum) as a source of uniform random deviates
* Pg. 294 from the book
*----------------------------------------------------------------
*/
float poidev(float xm, int *idum)
{
/* oldm is a flag for whether "xm" has changed since last call */
static float sq, alxm, g, oldm=(-1);
float em,t,y;
float gammln(float xx);
if(xm < 12.0){
if(xm != oldm){
oldm = xm;
g = exp(-xm);
}
em = -1;
t=1.0;
do{
++em;
t *= ran1(idum);
} while (t>g);
} else{
if (xm != oldm){
oldm = xm;
sq = sqrt(2.0*xm);
alxm = log(xm);
g = xm*alxm - gammln(xm+1.0);
}
do{
do{
y = tan(M_PI*ran1(idum));
em = sq * y + xm;
} while( em < 0.0);
em = floor(em);
t = 0.9*(1.0+y*y)*exp(em*alxm-gammln(em+1.0)-g);
} while( ran1(idum) > t);
}
return em;
}
