R_rgamma.c nmath.h work/git/mixpp/bdm/math/R_rgamma.c nmath.h repeat for(;;) double double rgamma (double a, double scale) rgamma double a double scale /* *Mathlib:ACLibraryofSpecialFunctions *Copyright(C)1998RossIhaka *Copyright(C)2000-2005TheRDevelopmentCoreTeam * *Thisprogramisfreesoftware;youcanredistributeitand/ormodify *itunderthetermsoftheGNUGeneralPublicLicenseaspublishedby *theFreeSoftwareFoundation;eitherversion2oftheLicense,or *(atyouroption)anylaterversion. * *Thisprogramisdistributedinthehopethatitwillbeuseful, *butWITHOUTANYWARRANTY;withouteventheimpliedwarrantyof *MERCHANTABILITYorFITNESSFORAPARTICULARPURPOSE.Seethe *GNUGeneralPublicLicenseformoredetails. * *YoushouldhavereceivedacopyoftheGNUGeneralPublicLicense *alongwiththisprogram;ifnot,acopyisavailableat *http://www.r-project.org/Licenses/ * *SYNOPSIS * *#include<Rmath.h> *doublergamma(doublea,doublescale); * *DESCRIPTION * *Randomvariatesfromthegammadistribution. * *REFERENCES * *[1]Shapeparametera>=1.AlgorithmGDin: * *Ahrens,J.H.andDieter,U.(1982). *Generatinggammavariatesbyamodified *rejectiontechnique. *Comm.ACM,25,47-54. * * *[2]Shapeparameter0<a<1.AlgorithmGSin: * *Ahrens,J.H.andDieter,U.(1974). *Computermethodsforsamplingfromgamma,beta, *poissonandbinomialdistributions. *Computing,12,223-246. * *Input:a=parameter(mean)ofthestandardgammadistribution. *Output:avariatefromthegamma(a)-distribution */ #include"nmath.h" #definerepeatfor(;;) doublergamma(doublea,doublescale) { /*Constants:*/ conststaticdoublesqrt32=5.656854; conststaticdoubleexp_m1=0.36787944117144232159;/*exp(-1)=1/e*/ /*Coefficientsq[k]-forq0=sum(q[k]*a^(-k)) *Coefficientsa[k]-forq=q0+(t*t/2)*sum(a[k]*v^k) *Coefficientse[k]-forexp(q)-1=sum(e[k]*q^k) */ conststaticdoubleq1=0.04166669; conststaticdoubleq2=0.02083148; conststaticdoubleq3=0.00801191; conststaticdoubleq4=0.00144121; conststaticdoubleq5=-7.388e-5; conststaticdoubleq6=2.4511e-4; conststaticdoubleq7=2.424e-4; conststaticdoublea1=0.3333333; conststaticdoublea2=-0.250003; conststaticdoublea3=0.2000062; conststaticdoublea4=-0.1662921; conststaticdoublea5=0.1423657; conststaticdoublea6=-0.1367177; conststaticdoublea7=0.1233795; /*Statevariables[FIXMEforthreading!]:*/ staticdoubleaa=0.; staticdoubleaaa=0.; staticdoubles,s2,d;/*no.1(step1)*/ staticdoubleq0,b,si,c;/*no.2(step4)*/ doublee,p,q,r,t,u,v,w,x,ret_val; if(!R_FINITE(a)||!R_FINITE(scale)||a<0.0||scale<=0.0) ML_ERR_return_NAN; if(a<1.){/*GSalgorithmforparametersa<1*/ if(a==0) return0.; e=1.0+exp_m1*a; repeat{ p=e*unif_rand(); if(p>=1.0){ x=-log((e-p)/a); if(exp_rand()>=(1.0-a)*log(x)) break; }else{ x=exp(log(p)/a); if(exp_rand()>=x) break; } } returnscale*x; } /*---a>=1:GDalgorithm---*/ /*Step1:Recalculationsofs2,s,difahaschanged*/ if(a!=aa){ aa=a; s2=a-0.5; s=sqrt(s2); d=sqrt32-s*12.0; } /*Step2:t=standardnormaldeviate, x=(s,1/2)-normaldeviate.*/ /*immediateacceptance(i)*/ t=norm_rand(); x=s+0.5*t; ret_val=x*x; if(t>=0.0) returnscale*ret_val; /*Step3:u=0,1-uniformsample.squeezeacceptance(s)*/ u=unif_rand(); if(d*u<=t*t*t) returnscale*ret_val; /*Step4:recalculationsofq0,b,si,cifnecessary*/ if(a!=aaa){ aaa=a; r=1.0/a; q0=((((((q7*r+q6)*r+q5)*r+q4)*r+q3)*r +q2)*r+q1)*r; /*Approximationdependingonsizeofparametera*/ /*Theconstantsintheexpressionsforb,siandc*/ /*wereestablishedbynumericalexperiments*/ if(a<=3.686){ b=0.463+s+0.178*s2; si=1.235; c=0.195/s-0.079+0.16*s; }elseif(a<=13.022){ b=1.654+0.0076*s2; si=1.68/s+0.275; c=0.062/s+0.024; }else{ b=1.77; si=0.75; c=0.1515/s; } } /*Step5:noquotienttestifxnotpositive*/ if(x>0.0){ /*Step6:calculationofvandquotientq*/ v=t/(s+s); if(fabs(v)<=0.25) q=q0+0.5*t*t*((((((a7*v+a6)*v+a5)*v+a4)*v +a3)*v+a2)*v+a1)*v; else q=q0-s*t+0.25*t*t+(s2+s2)*log(1.0+v); /*Step7:quotientacceptance(q)*/ if(log(1.0-u)<=q) returnscale*ret_val; } repeat{ /*Step8:e=standardexponentialdeviate *u=0,1-uniformdeviate *t=(b,si)-doubleexponential(laplace)sample*/ e=exp_rand(); u=unif_rand(); u=u+u-1.0; if(u<0.0) t=b-si*e; else t=b+si*e; /*Step9:rejectionift<tau(1)=-0.71874483771719*/ if(t>=-0.71874483771719){ /*Step10:calculationofvandquotientq*/ v=t/(s+s); if(fabs(v)<=0.25) q=q0+0.5*t*t* ((((((a7*v+a6)*v+a5)*v+a4)*v+a3)*v +a2)*v+a1)*v; else q=q0-s*t+0.25*t*t+(s2+s2)*log(1.0+v); /*Step11:hatacceptance(h)*/ /*(ifqnotpositivegotostep8)*/ if(q>0.0){ w=expm1(q); /*^^^^^originalcodehadapproximationwithrel.err<2e-7*/ /*iftisrejectedsampleagainatstep8*/ if(c*fabs(u)<=w*exp(e-0.5*t*t)) break; } } }/*repeat..until`t'isaccepted*/ x=s+0.5*t; returnscale*x*x; }