itpp_ext.cpp itpp_ext.h itpp_ext.h work/git/mixpp/bdm/itpp_ext.cpp itpp/itbase.h itpp log std::log exp std::exp sqrt std::sqrt R_FINITE std::isfinite void void dgeqrf_ (int *m, int *n, double *a, int *lda, double *tau, double *work, int *lwork, int *info) dgeqrf_ int * m int * n double * a int * lda double * tau double * work int * lwork int * info // //C++Implementation:itpp_ext // //Description: // // //Author:smidl<smidl@utia.cas.cz>,(C)2008 // //Copyright:SeeCOPYINGfilethatcomeswiththisdistribution // // #include"itpp_ext.h" //fromalgebra/lapack.h extern"C"{/*QRfactorizationofageneralmatrixA*/ voiddgeqrf_(int*m,int*n,double*a,int*lda,double*tau,double*work, int*lwork,int*info); }; namespaceitpp{ Array<int>to_Arr(constivec&indices){ Array<int>a(indices.size()); for(inti=0;i<a.size();i++){ a(i)=indices(i); } returna; } iveclinspace(intfrom,intto){ intn=to-from+1; inti; it_assert_debug(n>0,"wronglinspace"); iveciv(n);for(i=0;i<n;i++)iv(i)=from+i; returniv; }; voidset_subvector(vec&ov,constivec&iv,constvec&v) { it_assert_debug((iv.length()<=v.length()), "Vec<>::set_subvector(ivec,vec<Num_T>):Indexingout" "ofrangeofv"); for(inti=0;i<iv.length();i++){ it_assert_debug(iv(i)<ov.length(), "Vec<>::set_subvector(ivec,vec<Num_T>):Indexingout" "ofrangeofv"); ov(iv(i))=v(i); } } //Gamma Gamma_RNG::Gamma_RNG(doublea,doubleb){ setup(a,b); } bvecoperator&(constbvec&a,constbvec&b){ it_assert_debug(b.size()==a.size(),"operator&():Vectorsofdifferentlengths"); bvectemp(a.size()); for(inti=0;i<a.size();i++){ temp(i)=a(i)&b(i); } returntemp; } bvecoperator|(constbvec&a,constbvec&b){ it_assert_debug(b.size()!=a.size(),"operator&():Vectorsofdifferentlengths"); bvectemp(a.size()); for(inti=0;i<a.size();i++){ temp(i)=a(i)|b(i); } returntemp; } #definelogstd::log #defineexpstd::exp #definesqrtstd::sqrt #defineR_FINITEstd::isfinite doubleGamma_RNG::sample(){ //AcopyofrgammacodefromtheRpackage!! // /*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; doublea=alpha; doublescale=1.0/beta; if(!R_FINITE(a)||!R_FINITE(scale)||a<0.0||scale<=0.0) {it_error("Gamma_RNGwrongparameters");} if(a<1.){/*GSalgorithmforparametersa<1*/ if(a==0) return0.; e=1.0+exp_m1*a; for(;;){//VSrepeat 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; } for(;;){//VSrepeat /*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){ //TODO:w=expm1(q); w=exp(q)-1; /*^^^^^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; } boolqr(constmat&A,mat&R){ intinfo; intm=A.rows(); intn=A.cols(); intlwork=n; intk=std::min(m,n); vectau(k); vecwork(lwork); R=A; //performworkspacequeryforoptimumlworkvalue intlwork_tmp=-1; dgeqrf_(&m,&n,R._data(),&m,tau._data(),work._data(),&lwork_tmp, &info); if(info==0){ lwork=static_cast<int>(work(0)); work.set_size(lwork,false); } dgeqrf_(&m,&n,R._data(),&m,tau._data(),work._data(),&lwork,&info); //constructR for(inti=0;i<m;i++) for(intj=0;j<std::min(i,n);j++) R(i,j)=0; return(info==0); } }