/** Cumulative bivariate normal distribution.
Assumes two distributions X and Y both N(0,1).
\param xl Lower limit of inetegration on X.
\param yl Lower limit of inetegration on Y.
\param xu Upper limit of inetegration on X.
\param yu Upper limit of inetegration on Y.
\param rho correlation coefficient.
\return Probability that X is between xl and xu and Y is between yl and yu
*/
dvariable cumbvn(const dvariable& xl,const dvariable& yl,
const dvariable& xu,const dvariable& yu,const dvariable& rho)
{
RETURN_ARRAYS_INCREMENT();
dvariable my=cumbvn(xl,yl,rho);
my+=cumbvn(xu,yu,rho);
my-=cumbvn(xl,yu,rho);
my-=cumbvn(xu,yl,rho);
RETURN_ARRAYS_DECREMENT();
return my;
}
dvariable dstudent_t( const dvar_vector& residual, const dvar_vector& df)
{
RETURN_ARRAYS_INCREMENT();
double pi = 3.141593;
dvar_vector t1 = 0.5*(df+1);
dvar_vector t2 = gammln(t1);
dvar_vector t3 = 0.5*log(df*pi)+gammln(0.5*df);
dvar_vector t4 = elem_prod(t1,log(1+elem_div(square(residual),df)));
dvariable pdf = sum(t3+t4-t2);
RETURN_ARRAYS_DECREMENT();
return( pdf );
}
/**
* Description not yet available.
* \param
*/
dvar7_array operator/(const dvar7_array& m, const prevariable& d)
{
RETURN_ARRAYS_INCREMENT();
dvar7_array tmp;
tmp.allocate(m);
for (int i=tmp.indexmin();i<=tmp.indexmax();i++)
{
tmp(i)=m(i)/d;
}
RETURN_ARRAYS_DECREMENT();
return tmp;
}
/**
* Description not yet available.
* \param
*/
dvariable norm(const dvar_vector& t1)
{
RETURN_ARRAYS_INCREMENT();
dvariable tmp;
tmp=t1*t1;
if (value(tmp)>0.0)
{
tmp=pow(tmp,.5);
}
RETURN_ARRAYS_DECREMENT();
return(tmp);
}
dvariable robust_regression(dvector& obs, dvar_vector& pred,
const double& cutoff)
{
if (obs.indexmin() != pred.indexmin() || obs.indexmax() != pred.indexmax() )
{
cerr << "Index limits on observed vector are not equal to the Index\n\
limits on the predicted vector in robust_reg_likelihood function\n";
}
RETURN_ARRAYS_INCREMENT(); //Need this statement because the function
//returns a variable type
int min=obs.indexmin();
int max=obs.indexmax();
dvariable sigma_hat;
dvariable sigma_tilde;
int nobs = max-min+1;
double width=3.0;
double pcon=0.05;
double width2=width*width;
dvariable zpen;
zpen=0.0;
double a,a2;
a=cutoff;
// This bounds a between 0.05 and 1.75
a2=a*a;
dvariable tmp,tmp2,tmp4,sum_square,v_hat;
dvar_vector diff_vec = obs-pred;
tmp = norm(diff_vec);
sum_square = tmp * tmp;
v_hat = 1.e-80 + sum_square/nobs;
sigma_hat=pow(v_hat,.5);
sigma_tilde=a*sigma_hat;
double b=2.*pcon/(width*sqrt(PI));
dvariable log_likelihood;
dvariable div1;
dvariable div2,div4;
div1 = 2*(a2*v_hat);
div2 = width2*(a2*v_hat);
div4 = div2*div2;
log_likelihood = 0;
for (int i=min; i<=max; i++)
{
tmp=diff_vec[i];
tmp2=tmp*tmp;
tmp4=tmp2*tmp2;
log_likelihood -= log((1-pcon)*exp(-tmp2/div1)+b/(1.+tmp4/div4) );
}
log_likelihood += nobs*log(a2*v_hat)/2.;
log_likelihood += zpen;
RETURN_ARRAYS_DECREMENT(); // Need this to decrement the stack increment
// caused by RETURN_ARRAYS_INCREMENT();
return(log_likelihood);
}
/**
* Description not yet available.
* \param
*/
dvar_vector sfabs(const dvar_vector& t1)
{
RETURN_ARRAYS_INCREMENT();
dvar_vector tmp(t1.indexmin(),t1.indexmax());
for (int i=t1.indexmin(); i<=t1.indexmax(); i++)
{
tmp.elem(i)=sfabs(t1.elem(i));
}
RETURN_ARRAYS_DECREMENT();
return(tmp);
}
/** Compute the dot product of two variable type vectors. The minimum and maxium
legal subscripts of the arguments must agree; otherwize an error message
is printed and execution terminates.
\ingroup matop
\param v1 A dvar_vector, \f$a\f$.
\param v2 A dvar_vector, \f$b\f$.
\return A dvariable, \f$z = a\cdot b = \sum_i a_i\cdot b_i\f$ containing
the value of the dot product of the two arguments.
*/
dvariable operator*(const dvar_vector& v1, const dvar_vector& v2)
{
RETURN_ARRAYS_INCREMENT();
if (v1.indexmin()!=v2.indexmin()||v1.indexmax()!=v2.indexmax())
{
cerr << "Incompatible bounds in "
"prevariable operator * (const dvar_vector& v1, const dvar_vector& v2)"
<< endl;
ad_exit(1);
}
double tmp=0;
#ifndef USE_ASSEMBLER
int mmin=v1.indexmin();
int mmax=v1.indexmax();
#ifdef OPT_LIB
double * pt1=&v1.elem_value(mmin);
double * pt1m=&v1.elem_value(mmax);
double * pt2=&v2.elem_value(mmin);
do
{
tmp+= *pt1++ * *pt2++;
}
while (pt1<=pt1m);
#else
for (int i=mmin; i<=mmax; i++)
{
tmp+=v1.elem_value(i)*v2.elem_value(i);
}
#endif
#else
int mmin=v1.indexmin();
int n=v1.indexmax()-mmin+1;
dp_dotproduct(&tmp,&(v1.elem_value(mmin)),&(v2.elem_value(mmin)),n);
#endif
dvariable vtmp=nograd_assign(tmp);
// The derivative list considerations
save_identifier_string("bbbb");
v1.save_dvar_vector_value();
v1.save_dvar_vector_position();
v2.save_dvar_vector_value();
v2.save_dvar_vector_position();
vtmp.save_prevariable_position();
save_identifier_string("aaaa");
gradient_structure::GRAD_STACK1->
set_gradient_stack(dvdv_dot);
RETURN_ARRAYS_DECREMENT();
return vtmp;
}
/**
\ingroup matop
Matrix exponential.
The matrix exponential is calculated using the Pade approximation adapted from Moler, Cleve; Van Loan, Charles F. (2003), "Nineteen Dubious Ways to Compute the Exponential of a Matrix, Twenty-Five Years Later"
The main use of the matrix exponential is to solve linear ordinary differential equation (ODE) systems:
\f[
\frac{d}{dt}y(t) = Ay(t)\ , \ \mbox{with } y(0) = y_0
\f]
\item then the solution becomes
\f[
y(t) = e^{At}y_0
\f]
\param A square df1b2matrix
\returns The matrix exponential of A
*/
df1b2matrix expm(const df1b2matrix & A)
{
RETURN_ARRAYS_INCREMENT();
int rmin = A.rowmin();
int rmax = A.rowmax();
if(rmax != A.colmax())
{cout<<"Error: Not square matrix in expm."<<endl; ad_exit(1);}
if(rmin != A.colmin())
{cout<<"Error: Not square matrix in expm."<<endl; ad_exit(1);}
df1b2matrix I(rmin,rmax,rmin,rmax);
df1b2matrix AA(rmin,rmax,rmin,rmax);
df1b2matrix X(rmin,rmax,rmin,rmax);
df1b2matrix E(rmin,rmax,rmin,rmax);
df1b2matrix D(rmin,rmax,rmin,rmax);
df1b2matrix cX(rmin,rmax,rmin,rmax);
I.initialize();
for(int i = rmin; i<=rmax; ++i){I(i,i) = 1.0;}
df1b2variable log2NormInf;
log2NormInf = log(max(rowsum(fabs(value(A)))));
log2NormInf/=log(2.0);
int e = (int)value(log2NormInf) + 1;
int s = e+1;
s = (s<0) ? 0 : s;
AA = 1.0/pow(2.0,s)*A;
X = AA;
df1b2variable c = 0.5;
E = I+c*AA;
D = I-c*AA;
int q = 6, p = 1;
for(int k = 2; k<=q; ++k){
c*=((double)q-k+1.0)/((double)k*(2*q-k+1));
X = AA*X;
cX = c*X;
E+=cX;
if(p==1){D+=cX;}else{D-=cX;}
p = (p==1) ? 0 : 1;
}
// E = inv(D)*E;
E = solve(D,E);
for(int k = 1; k<=s; ++k){
E = E*E;
}
RETURN_ARRAYS_DECREMENT();
return E;
}
/**
\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;
}
dvariable log_negbinomial_density(double x,const prevariable& mu,
const prevariable& tau)
{
if (value(tau)-1.0<0.0)
{
cerr << "tau <=1 in log_negbinomial_density " << endl;
ad_exit(1);
}
RETURN_ARRAYS_INCREMENT();
dvariable r=mu/(1.e-120+(tau-1));
dvariable tmp;
tmp=gammln(x+r)-gammln(r) -gammln(x+1)
+r*log(r)+x*log(mu)-(r+x)*log(r+mu);
RETURN_ARRAYS_DECREMENT();
return tmp;
}
/**
* Description not yet available.
* \param
*/
dvar_vector operator-(const dvar_vector& t1, const double x)
{
RETURN_ARRAYS_INCREMENT();
dvar_vector tmp(t1.indexmin(),t1.indexmax());
save_identifier_string("ucbb");
for (int i=t1.indexmin(); i<=t1.indexmax(); i++)
{
tmp.elem_value(i)=t1.elem_value(i)-x;
}
tmp.save_dvar_vector_position();
t1.save_dvar_vector_position();
save_identifier_string("dduu");
RETURN_ARRAYS_DECREMENT();
gradient_structure::GRAD_STACK1->set_gradient_stack(DF_dv_cdble_diff);
return(tmp);
}
/** negative log likelihood of negative binomial with mean and tau
\brief Negative binomial with mean=mu and variance = mu*tau
\author Mollie Brooks
\param x observed count
\param mu is the predicted mean
\param tau is the overdispersion parameter like in the quasi-poisson. should be >1
\return negative log likelihood \f$ -( \ln(\Gamma(x+k))-\ln(\Gamma(k))-\ln(x!)+k\ln(k)+x\ln(\mu)-(k+x)\ln(k+\mu) )\f$
where \f$ k=\mu/(10^{-120}+\tau-1.0) \f$
\ingroup STATLIB
**/
df1b2variable dnbinom_tau(const double& x, const df1b2variable& mu, const df1b2variable& tau)
{
//x is the observed count
//mu is the predicted mean
//tau is the overdispersion parameter
if (value(tau)<1.0)
{
cerr<<"tau is <=1.0 in dnbinom_tau()";
return(0.0);
}
RETURN_ARRAYS_INCREMENT();
df1b2variable loglike;
loglike = log_negbinomial_density(x, mu, tau);
RETURN_ARRAYS_DECREMENT();
return(-loglike);
}
/**
* Description not yet available.
* \param
*/
dvar_vector operator+(const prevariable& x, const dvar_vector& t1)
{
RETURN_ARRAYS_INCREMENT();
dvar_vector tmp(t1.indexmin(),t1.indexmax());
save_identifier_string("wcbf");
x.save_prevariable_position();
for (int i=t1.indexmin(); i<=t1.indexmax(); i++)
{
tmp.elem_value(i)=t1.elem_value(i)+value(x);
}
tmp.save_dvar_vector_position();
t1.save_dvar_vector_position();
save_identifier_string("dduu");
RETURN_ARRAYS_DECREMENT();
gradient_structure::GRAD_STACK1->set_gradient_stack(DF_dble_dv_add);
return(tmp);
}
/******************************************************************
* Calculate log prior probability. *
******************************************************************/
dvariable NumberInfo::calcLogPrior(prevariable& x){
RETURN_ARRAYS_INCREMENT();
if (debug) cout<<"starting NumberInfo::calcLogPrior(prevariable& x)"<<this<<endl;
dvariable val = pMPI->calcLogPDF(x,priorParams,priorConsts);
if (debug) {
if (pMPI->getNumParams()) cout<<"priorParams = "<<priorParams<<tb;
if (pMPI->getNumConsts()) cout<<"priorConsts = "<<priorConsts<<tb;
cout<<endl;
cout<<"x = "<<x<<"; ln(pdf(x)) = "<<val<<endl;
cout<<"finished NumberInfo::calcLogPrior(prevariable& x)"<<this<<endl;
cout<<"Enter 1 to continue: ";
cin>>debug;
if (debug<0) exit(1);
}
RETURN_ARRAYS_DECREMENT();
return val;
}
/**
\author Steven James Dean Martell
\date 2011-06-21
\param x a differentiable vector
\param mu is a prevariable log mean
\param std a prevariable log standard deviation
\return returns the negative loglikelihood of the lognormal distribution
\sa
**/
dvariable dlnorm( const dvar_vector& x, const prevariable& mu, const prevariable& std )
{
if( std<=0 || min(x)<=0 )
{
cerr<<"Standard deviation or the mix(x) is less than or equal to zero in "
"dlnorm( const dvar_vector& x, const dvariable& mu, const dvariable& std )\n";
return 0;
}
RETURN_ARRAYS_INCREMENT();
long n=size_count(x);
dvariable ss = norm2( log(x)-mu );
dvariable t1 = n*(0.5*log(2*M_PI)+log(std));
dvariable nloglike = t1 + sum(log(x)) + ss/(2.*std*std);
RETURN_ARRAYS_DECREMENT();
return nloglike;
}
/**
* Description not yet available.
* \param
*/
dvar_vector dvar_vector::operator- (void)
{
RETURN_ARRAYS_INCREMENT();
int mmin=indexmin();
int mmax=indexmax();
dvar_vector tmp(mmin,mmax);
save_identifier_string("ec");
for (int i=mmin; i<=mmax; i++)
{
tmp.elem_value(i)=-elem_value(i);
}
tmp.save_dvar_vector_position();
save_dvar_vector_position();
save_identifier_string("d");
RETURN_ARRAYS_DECREMENT();
gradient_structure::GRAD_STACK1->set_gradient_stack(DF_unary_diff);
return(tmp);
}
//
// First the dvar_matrix version.
dvar_vector CalcPSS(_CONST dvar_matrix& DevX, _CONST dvariable& DevSD,
int MinJ, double NA)
{
RETURN_ARRAYS_INCREMENT();
// Determine and check sizes.
int ibot = DevX.rowmin();
int itop = DevX.rowmax();
int jbot = DevX.colmin();
int jtop = DevX.colmax();
//
if (MinJ < jbot || MinJ > jtop)
{
cerr << "error in CalcPSS: start column out of range" << endl;
exit(1);
}
//
// Check DevSD.
if (DevSD == 0.0 || DevSD == NA)
{
cerr << "error in CalcPSS: bumDevSD" << endl;
exit(1);
}
// Run through cells.
int n = 0;
dvariable PSS = 0.0;
dvariable sdev;
for (int i = ibot; i<=itop; i++)
for (int j = MinJ; j<=jtop; j++)
{
// Skip if any item is NA.
if ( DevX(i,j) == NA ) continue;
// Add to accumulators.
n++;
sdev = DevX(i,j)/DevSD;
PSS += sdev * sdev;
}
// Load return vector.
dvar_vector PSS_vec(1,3);
PSS_vec(1) = PSS;
PSS_vec(2) = n;
PSS_vec(3) = sqrt(PSS/n);
RETURN_ARRAYS_DECREMENT();
return(PSS_vec);
}
//
// Next the dvar_vector (arg) version.
dvar_vector CalcPSS(_CONST dvar_vector& DevX, _CONST dvariable& DevSD,
int MinI, double NA)
{
RETURN_ARRAYS_INCREMENT();
// Determine and check sizes.
int ibot = DevX.indexmin();
int itop = DevX.indexmax();
//
if (MinI < ibot || MinI > itop)
{
cerr << "error in CalcPSS: start element out of range" << endl;
exit(1);
}
//
// Check SD.
if (DevSD == 0.0 || DevSD == NA)
{
cerr << "error in CalcPSS: bum DevSD" << endl;
exit(1);
}
// Run through cells.
int n = 0;
dvariable PSS = 0.0;
dvariable sdev;
for (int i = MinI; i<=itop; i++)
{
// Skip if any item is NA.
if ( DevX(i) == NA ) continue;
// Add to accumulators.
n++;
sdev = DevX(i)/DevSD;
PSS += sdev * sdev;
}
// Load return vector.
dvar_vector PSS_vec(1,3);
PSS_vec(1) = PSS;
PSS_vec(2) = n;
PSS_vec(3) = sqrt(PSS/n);
RETURN_ARRAYS_DECREMENT();
return(PSS_vec);
}
/** negative log likelihood of negative binomial with mean and tau
\brief Negative binomial with mean=mu and variance = mu*tau
\author Mollie Brooks
\param x observed counts
\param mu is the predicted mean
\param tau is the overdispersion parameter like in the quasi-poisson. should be >1
\return negative log likelihood \f$ -( \ln(\Gamma(x+k))-\ln(\Gamma(k))-\ln(x!)+k\ln(k)+x\ln(\mu)-(k+x)\ln(k+\mu) )\f$
where \f$ k=\mu/(10^{-120}+\tau-1.0) \f$
\ingroup STATLIB
**/
df1b2variable dnbinom_tau(const dvector& x, const df1b2vector& mu, const df1b2variable& tau)
{
//the observed counts are in x
//mu is the predicted mean
//tau is the overdispersion parameter
if (value(tau)<1.0)
{
cerr<<"tau is <=1.0 in dnbinom_tau()";
return(0.0);
}
RETURN_ARRAYS_INCREMENT();
int i,imin,imax;
imin=x.indexmin();
imax=x.indexmax();
df1b2variable loglike;
loglike=0.;
for(i = imin; i<=imax; i++)
{
loglike += log_negbinomial_density(x(i), mu(i), tau);
}
RETURN_ARRAYS_DECREMENT();
return(-loglike);
}
/**
* Description not yet available.
* \param
*/
dvar_vector operator*(const dvar_matrix& m, const dvector& x)
{
RETURN_ARRAYS_INCREMENT();
if (x.indexmin() != m.colmin() || x.indexmax() != m.colmax())
{
cerr << " Incompatible array bounds in "
"dvar_vector operator * (const dvar_matrix& m, const dvar_vector& x)\n";
ad_exit(21);
}
kkludge_object kkk;
dvar_vector tmp(m.rowmin(),m.rowmax(),kkk);
double sum;
for (int i=m.rowmin(); i<=m.rowmax(); i++)
{
sum=0.0;
const dvar_vector& tt=m.elem(i);
for (int j=x.indexmin(); j<=x.indexmax(); j++)
{
//sum+=m[i][j]*x[j];
sum+=tt.elem_value(j)*x.elem(j);
}
tmp.elem_value(i)=sum;
}
save_identifier_string("PL4");
x.save_dvector_value();
x.save_dvector_position();
m.save_dvar_matrix_position();
tmp.save_dvar_vector_position();
save_identifier_string("PLX");
gradient_structure::GRAD_STACK1->
set_gradient_stack(dmcv_prod);
RETURN_ARRAYS_DECREMENT();
return(tmp);
}
/**
* Description not yet available.
* \param
*/
dvariable ghk(const dvar_vector& lower,const dvar_vector& upper,
const dvar_matrix& Sigma, const dmatrix& eps)
{
RETURN_ARRAYS_INCREMENT();
int n=lower.indexmax();
int m=eps.indexmax();
dvariable ssum=0.0;
dvar_matrix ch=choleski_decomp(Sigma);
dvar_vector l(1,n);
dvar_vector u(1,n);
for (int k=1;k<=m;k++)
{
dvariable weight=1.0;
l=lower;
u=upper;
for (int j=1;j<=n;j++)
{
l(j)/=ch(j,j);
u(j)/=ch(j,j);
dvariable Phiu=cumd_norm(u(j));
dvariable Phil=cumd_norm(l(j));
weight*=Phiu-Phil;
dvariable eta=inv_cumd_norm((Phiu-Phil)*eps(k,j)+Phil+1.e-30);
for (int i=j+1;i<=n;i++)
{
dvariable tmp=ch(i,j)*eta;
l(i)-=tmp;
u(i)-=tmp;
}
}
ssum+=weight;
}
RETURN_ARRAYS_DECREMENT();
return ssum/m;
}
/**
* Description not yet available.
* \param
*/
dvar_vector operator*(const dvector& x, const dvar_matrix& m)
{
RETURN_ARRAYS_INCREMENT();
if (x.indexmin() != m.rowmin() || x.indexmax() != m.rowmax())
{
cerr << " Incompatible array bounds in "
"dvar_vector operator*(const dvector& x, const dvar_matrix& m)\n";
ad_exit(21);
}
dvar_vector tmp(m.colmin(),m.colmax());
dvariable sum;
for (int j=m.colmin(); j<=m.colmax(); j++)
{
sum=0.0;
for (int i=x.indexmin(); i<=x.indexmax(); i++)
{
sum+=x.elem(i)*m.elem(i,j);
}
tmp[j]=sum;
}
RETURN_ARRAYS_DECREMENT();
return(tmp);
}
//
// First the dvar_matrix version.
dvar_vector CalcRSS(_CONST dvar_matrix& PredX, _CONST dvar_matrix& ObsX,
_CONST dvar_matrix& SDX, double SDevPow, int MinJ,
int MaxI, double NA)
{
RETURN_ARRAYS_INCREMENT();
// Determine and check sizes.
int ibot = ObsX.rowmin();
int itop = ObsX.rowmax();
int jbot = ObsX.colmin();
int jtop = ObsX.colmax();
//
if (MinJ < jbot || MinJ > jtop)
{
cerr << "error in CalcRSS: start column out of range" << endl;
exit(1);
}
if (MaxI < ibot || MaxI > itop)
{
cerr << "error in CalcRSS: end row out of range" << endl;
exit(1);
}
if ( SDX.rowmin() != ibot ||
SDX.rowmax() != itop ||
SDX.colmin() != jbot ||
SDX.colmax() != jtop )
{
cerr << "error in CalcRSS: dimensions of SD matrix" << endl;
exit(1);
}
if ( PredX.rowmin() != ibot ||
PredX.rowmax() != itop ||
PredX.colmin() > MinJ ||
PredX.colmax() != jtop )
{
cerr << "error in CalcRSS: dimensions of Pred matrix" << endl;
exit(1);
}
//
// Run through cells.
int n = 0;
dvariable RSS = 0.0;
dvariable sdev;
for (int i = ibot; i<=MaxI; i++)
for (int j = MinJ; j<=jtop; j++)
{
// Skip if any item is NA.
if ( PredX(i,j) == NA ||
ObsX(i,j) == NA ||
SDX(i,j) == NA ) continue;
// Bail if SD is zero.
if (SDX(i,j) == 0.0)
{
cerr << "error in CalcRSS: zero SD" << endl;
exit(1);
}
// Add to accumulators.
sdev = fabs((PredX(i,j) - ObsX(i,j))/SDX(i,j));
n++;
RSS += pow(sdev, SDevPow);
} // End loop on i and j.
// Load return vector.
dvar_vector RSS_vec(1,3);
RSS_vec(1) = RSS;
RSS_vec(2) = n;
RSS_vec(3) = RSS/n;
RETURN_ARRAYS_DECREMENT();
return(RSS_vec);
}
/**
* Description not yet available.
* \param
\n\n The implementation of this algorithm was inspired by
"Numerical Recipes in C", 2nd edition,
Press, Teukolsky, Vetterling, Flannery, chapter xx
*/
df1b2matrix solve(const df1b2matrix& aa,const df1b2matrix& tz,
df1b2variable ln_unsigned_det,df1b2variable& sign)
{
RETURN_ARRAYS_INCREMENT();
int n = aa.colsize();
int lb = aa.colmin();
int ub = aa.colmax();
if (lb!=aa.rowmin()||ub!=aa.colmax())
{
cerr << "Error matrix not square in solve()"<<endl;
ad_exit(1);
}
df1b2matrix bb(lb,ub,lb,ub);
bb = aa;
ivector indx(lb,ub);
int One = 1;
indx.fill_seqadd(lb,One);
df1b2variable d;
df1b2variable big,dum,sum,temp;
df1b2vector vv(lb,ub);
d = 1.0;
for (int i = lb;i<=ub;i++)
{
big = 0.0;
for (int j = lb;j<=ub;j++)
{
temp = fabs(bb(i,j));
if (value(temp) > value(big))
{
big = temp;
}
}
if (value(big) == 0.0)
{
cerr <<
"Error in matrix inverse -- matrix singular in inv(df1b2matrix)\n";
}
vv[i] = 1.0/big;
}
for (int j = lb;j<=ub;j++)
{
for (int i = lb;i<j;i++)
{
sum = bb(i,j);
for (int k = lb;k<i;k++)
{
sum -= bb(i,k)*bb(k,j);
}
// a[i][j] = sum;
bb(i,j) = sum;
}
int imax = j;
big = 0.0;
for (int i = j;i<=ub;i++)
{
sum = bb(i,j);
for (int k = lb;k<j;k++)
{
sum -= bb(i,k)*bb(k,j);
}
bb(i,j) = sum;
dum = vv[i]*fabs(sum);
if (value(dum) >= value(big))
{
big = dum;
imax = i;
}
}
if (j != imax)
{
for (int k = lb;k<=ub;k++)
{
dum = bb(imax,k);
bb(imax,k) = bb(j,k);
bb(j,k) = dum;
}
d = -1.*d;
vv[imax] = vv[j];
// if (j<ub)
{
int itemp = indx(imax);
indx(imax) = indx(j);
indx(j) = itemp;
}
// cout << "indx= " <<indx<<endl;
}
if (value(bb(j,j)) == value(0.0))
{
bb(j,j) = TINY;
}
if (j != n)
{
dum = 1.0/bb(j,j);
for (int i = j+1;i<=ub;i++)
{
bb(i,j) = bb(i,j) * dum;
}
}
}
// get the determinant
sign = d;
df1b2vector part_prod(lb,ub);
part_prod(lb) = log(fabs(bb(lb,lb)));
if (value(bb(lb,lb))<0) sign=-sign;
for (int j = lb+1;j<=ub;j++)
{
if (value(bb(j,j))<0) sign=-sign;
part_prod(j) = part_prod(j-1)+log(fabs(bb(j,j)));
}
ln_unsigned_det = part_prod(ub);
df1b2matrix z = trans(tz);
int mmin = z.indexmin();
int mmax = z.indexmax();
df1b2matrix x(mmin,mmax,lb,ub);
// df1b2vector x(lb,ub);
df1b2vector y(lb,ub);
// int lb = rowmin;
// int ub = rowmax;
df1b2matrix& b = bb;
ivector indxinv(lb,ub);
for (int i = lb;i<=ub;i++)
{
indxinv(indx(i)) = i;
}
for (int kk = mmin;kk<=mmax;kk++)
{
for (int i = lb;i<=ub;i++)
{
y(indxinv(i)) = z(kk)(i);
}
for (int i = lb;i<=ub;i++)
{
sum = y(i);
for (int j = lb;j<=i-1;j++)
{
sum-=b(i,j)*y(j);
}
y(i) = sum;
}
for (int i = ub;i>=lb;i--)
{
sum = y(i);
for (int j = i+1;j<=ub;j++)
{
sum-=b(i,j)*x(kk)(j);
}
x(kk)(i) = sum/b(i,i);
}
}
RETURN_ARRAYS_DECREMENT();
return trans(x);
}
//
// Next the dvar_vector (arg) version.
dvar_vector CalcRSS(_CONST dvar_vector& PredX, _CONST dvar_vector& ObsX,
_CONST dvar_vector& SDX, double SDevPow, int MinI,
int MaxI, double NA)
{
RETURN_ARRAYS_INCREMENT();
// Determine and check sizes.
int ibot = ObsX.indexmin();
int itop = ObsX.indexmax();
//
if (MinI < ibot || MinI > itop)
{
cerr << "error in CalcRSS: start point out of range" << endl;
exit(1);
}
if (MaxI < ibot || MaxI > itop)
{
cerr << "error in CalcRSS: end point out of range" << endl;
exit(1);
}
if ( SDX.indexmin() != ibot ||
SDX.indexmax() != itop )
{
cerr << "error in CalcRSS: indices of SD vector" << endl;
exit(1);
}
if ( PredX.indexmin() > MinI ||
PredX.indexmax() != itop )
{
cerr << "error in CalcRSS: indices of Pred vector" << endl;
exit(1);
}
//
// Run through cells.
int n = 0;
dvariable RSS = 0.0;
dvariable sdev;
for (int i = MinI; i<=MaxI; i++)
{
// Skip if any item is NA.
if ( PredX(i) == NA ||
ObsX(i) == NA ||
SDX(i) == NA ) continue;
// Bail if SD is zero.
if (SDX(i) == 0.0)
{
cerr << "error in CalcRSS: zero SD" << endl;
exit(1);
}
// Add to accumulators.
sdev = fabs((PredX(i) - ObsX(i))/SDX(i));
n++;
RSS += pow(sdev, SDevPow);
} // End loop on i.
// Load return vector.
dvar_vector RSS_vec(1,3);
RSS_vec(1) = RSS;
RSS_vec(2) = n;
RSS_vec(3) = RSS/n;
RETURN_ARRAYS_DECREMENT();
return(RSS_vec);
}
/**
* Description not yet available.
* \param
*/
dvariable inv_cumd_norm_inner(const prevariable& x)
{
if (++gradient_structure::RETURN_PTR > gradient_structure::MAX_RETURN)
gradient_structure::RETURN_PTR = gradient_structure::MIN_RETURN;
RETURN_ARRAYS_INCREMENT();
const double c0=2.515517;
const double c1=0.802853;
const double c2=0.010328;
const double d1=1.432788;
const double d2=0.189269;
const double d3=0.001308;
if (x<=0 || x>=1.0)
{
//cerr << "Illegal argument to inv_cumd_norm = " << x << endl;
RETURN_ARRAYS_DECREMENT();
return 0.0;
}
if (x<=0.5)
{
//dvariable t = sqrt(-2.*log(x));
//dvariable p=((c2*t+c1)*t+c0)/((((d3*t+d2)*t+d1)*t)+1)-t;
//RETURN_ARRAYS_DECREMENT();
//return p;
double tt = sqrt(-2.*log(value(x)));
double u=(c2*tt+c1)*tt+c0;
double v=((d3*tt+d2)*tt+d1)*tt+1;
double vinv=1.0/v;
double pp=u*vinv-tt;
//double pp=u*vinv-tt;
double dfu=vinv;
double dfvinv=u;
double dftt=-1.0;
//double vinv=1.0/v;
double dfv=-vinv*vinv*dfvinv;
//double v=((d3*tt+d2)*tt+d1)*tt+1;
dftt+=((3*d3*tt+2.0*d2)*tt+d1)*dfv;
//double u=(c2*tt+c1)*tt+c0;
dftt+=(2.0*c2*tt+c1)*dfu;
//double tt = sqrt(-2.*log(value(x)));
double dfx=-1.0/(tt*value(x))*dftt;
RETURN_ARRAYS_DECREMENT();
gradient_structure::RETURN_PTR->v->x=pp;
gradient_structure::GRAD_STACK1->set_gradient_stack(default_evaluation,
&(gradient_structure::RETURN_PTR->v->x), &(x.v->x),dfx);
return(*gradient_structure::RETURN_PTR);
}
else if (x==0.5)
{
cout << "can't happen" << endl;
exit(1);
//return 0.0;
}
else
{
//dvariable y=1.-x;
//dvariable t = sqrt(-2.*log(y));
//dvariable p=t-((c2*t+c1)*t+c0)/((((d3*t+d2)*t+d1)*t)+1);
//RETURN_ARRAYS_DECREMENT();
//return p;
double yy=1.-value(x);
double tt = sqrt(-2.*log(yy));
double u=((c2*tt+c1)*tt+c0);
double v=((d3*tt+d2)*tt+d1)*tt+1;
double vinv=1/v;
double pp=tt-u*vinv;
//double pp=tt-u*vinv;
double dfu=-vinv;
double dfvinv=-u;
double dftt=1.0;
//double vinv=1.0/v;
double dfv=-vinv*vinv*dfvinv;
//double v=((d3*tt+d2)*tt+d1)*tt+1;
dftt+=((3*d3*tt+2.0*d2)*tt+d1)*dfv;
//double u=(c2*tt+c1)*tt+c0;
dftt+=(2.0*c2*tt+c1)*dfu;
//double tt = sqrt(-2.*log(yy));
double dfy=-1.0/(tt*yy)*dftt;
//double yy=1.-value(x);
double dfx=-dfy;
RETURN_ARRAYS_DECREMENT();
gradient_structure::RETURN_PTR->v->x=pp;
gradient_structure::GRAD_STACK1->set_gradient_stack(default_evaluation,
&(gradient_structure::RETURN_PTR->v->x), &(x.v->x),dfx);
return(*gradient_structure::RETURN_PTR);
}
}
/* larger than SK. */
double cmvbvu_(const double *sh,const double *sk,const double *r__)
{
RETURN_ARRAYS_INCREMENT();
/* Initialized data */
static struct {
doublereal e_1[3];
doublereal fill_2[7];
doublereal e_3[6];
doublereal fill_4[4];
doublereal e_5[10];
} equiv_21 = { {.1713244923791705, .3607615730481384,
.4679139345726904}, {0, 0, 0, 0, 0, 0, 0},
{.04717533638651177, .1069393259953183,
.1600783285433464, .2031674267230659, .2334925365383547,
.2491470458134029}, {0, 0, 0, 0}, {.01761400713915212,
.04060142980038694, .06267204833410906, .08327674157670475,
.1019301198172404, .1181945319615184, .1316886384491766,
.1420961093183821, .1491729864726037, .1527533871307259}};
#define w ((doublereal *)&equiv_21)
static struct {
doublereal e_1[3];
doublereal fill_2[7];
doublereal e_3[6];
doublereal fill_4[4];
doublereal e_5[10];
} equiv_22 = { {-.9324695142031522, -.6612093864662647,
-.238619186083197}, {0, 0, 0, 0, 0, 0, 0}, {-.9815606342467191,
-.904117256370475,
-.769902674194305, -.5873179542866171, -.3678314989981802,
-.1252334085114692}, {0, 0, 0, 0}, {-.9931285991850949,
-.9639719272779138, -.9122344282513259, -.8391169718222188,
-.7463319064601508, -.636053680726515, -.5108670019508271,
-.3737060887154196, -.2277858511416451, -.07652652113349733}};
#define x ((doublereal *)&equiv_22)
/* System generated locals */
integer i__1;
double ret_val, d__1, d__2,d__3,d__4;
/* Builtin functions */
//double asin(doublereal), sin(doublereal), exp(doublereal), sqrt(
// doublereal);
/* Local variables */
static double a, b, c__, d__, h__;
static integer i__;
//static doublereal k;
static double k;
extern double cmvphi_(double *);
static integer lg;
//static doublereal as;
static double as;
static integer ng;
static double bs,rs,xs;
static double hs, hk, sn, asr, bvn;
/* A function for computing bivariate normal probabilities; */
/* developed using */
/* Drezner, Z. and Wesolowsky, G. O. (1989), */
/* On the Computation of the Bivariate Normal Integral, */
/* J. Stat. Comput. Simul.. 35 pp. 101-107. */
/* with extensive modications for double precisions by */
/* Alan Genz and Yihong Ge */
/* Department of Mathematics */
/* Washington State University */
/* Pullman, WA 99164-3113 */
/* Email : [email protected] */
/* BVN - calculate the probability that X is larger than SH and Y is */
/* larger than SK. */
/* Parameters */
/* SH REAL, integration limit */
/* SK REAL, integration limit */
/* R REAL, correlation coefficient */
/* LG INTEGER, number of Gauss Rule Points and Weights */
/* Gauss Legendre Points and Weights, N = 6 */
/* Gauss Legendre Points and Weights, N = 12 */
/* Gauss Legendre Points and Weights, N = 20 */
if (abs(*r__) < (float).3) {
ng = 1;
lg = 3;
} else if (abs(*r__) < (float).75) {
ng = 2;
lg = 6;
} else {
ng = 3;
lg = 10;
}
h__ = *sh;
k = *sk;
hk = h__ * k;
bvn = 0.;
if (abs(*r__) < (float).925) {
hs = (h__ * h__ + k * k) / 2;
asr = asin(*r__);
i__1 = lg;
for (i__ = 1; i__ <= i__1; ++i__) {
sn = sin(asr * (x[i__ + ng * 10 - 11] + 1) / 2);
bvn += w[i__ + ng * 10 - 11] * exp((sn * hk - hs) / (1 - sn * sn));
sn = sin(asr * (-x[i__ + ng * 10 - 11] + 1) / 2);
bvn += w[i__ + ng * 10 - 11] * exp((sn * hk - hs) / (1 - sn * sn));
}
d__1 = -h__;
d__2 = -k;
bvn = bvn * asr / 12.566370614359172 + cmvphi_(&d__1) * cmvphi_(&d__2);
} else {
if (*r__ < 0.) {
k = -k;
hk = -hk;
}
if (abs(*r__) < 1.) {
as = (1 - *r__) * (*r__ + 1);
a = sqrt(as);
/* Computing 2nd power */
d__1 = h__ - k;
bs = d__1 * d__1;
c__ = (4 - hk) / 8;
d__ = (12 - hk) / 16;
bvn = a * exp(-(bs / as + hk) / 2) * (1 - c__ * (bs - as) * (1 -
d__ * bs / 5) / 3 + c__ * d__ * as * as / 5);
if (hk > -160.) {
b = sqrt(bs);
d__1 = -b / a;
bvn -= exp(-hk / 2) * sqrt(6.283185307179586) * cmvphi_(&d__1)
* b * (1 - c__ * bs * (1 - d__ * bs / 5) / 3);
}
a /= 2;
i__1 = lg;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing 2nd power */
d__1 = a * (x[i__ + ng * 10 - 11] + 1);
xs = d__1 * d__1;
rs = sqrt(1 - xs);
bvn += a * w[i__ + ng * 10 - 11] * (exp(-bs / (xs * 2) - hk /
(rs + 1)) / rs - exp(-(bs / xs + hk) / 2) * (c__ * xs
* (d__ * xs + 1) + 1));
/* Computing 2nd power */
d__1 = -x[i__ + ng * 10 - 11] + 1;
xs = as * (d__1 * d__1) / 4;
rs = sqrt(1 - xs);
bvn += a * w[i__ + ng * 10 - 11] * exp(-(bs / xs + hk) / 2) *
(exp(-hk * (1 - rs) / ((rs + 1) * 2)) / rs - (c__ *
xs * (d__ * xs + 1) + 1));
}
bvn = -bvn / 6.283185307179586;
}
if (*r__ > 0.) {
d__1 = -max(h__,k);
bvn += cmvphi_(&d__1);
}
if (*r__ < 0.) {
/* Computing MAX */
d__3 = -h__;
d__4 = -k;
d__1 = 0., d__2 = cmvphi_(&d__3) - cmvphi_(&d__4);
bvn = -bvn + max(d__1,d__2);
}
}
ret_val = bvn;
RETURN_ARRAYS_DECREMENT();
return ret_val;
} /* cmvbvu_ */
double cmvphi_(double *z__)
{
RETURN_ARRAYS_INCREMENT();
/* System generated locals */
doublereal ret_val, d__1;
/* Builtin functions */
#if !defined(USE_DDOUBLE)
double exp(doublereal);
#endif
/* Local variables */
static doublereal zabs, p, expntl;
/* Normal distribution probabilities accurate to 1.e-15. */
/* Z = no. of standard deviations from the mean. */
/* Based upon algorithm 5666 for the error function, from: */
/* Hart, J.F. et al, 'Computer Approximations', Wiley 1968 */
/* Programmer: Alan Miller */
/* Latest revision - 30 March 1986 */
zabs = abs(*z__);
/* |Z| > 37 */
if (zabs > 37.) {
p = 0.;
} else {
/* |Z| <= 37 */
/* Computing 2nd power */
d__1 = zabs;
expntl = exp(-(d__1 * d__1) / 2);
/* |Z| < CUTOFF = 10/SQRT(2) */
if (zabs < 7.071067811865475) {
p = expntl * ((((((zabs * .03526249659989109 + .7003830644436881)
* zabs + 6.37396220353165) * zabs + 33.912866078383) *
zabs + 112.0792914978709) * zabs + 221.2135961699311) *
zabs + 220.2068679123761) / (((((((zabs *
.08838834764831844 + 1.755667163182642) * zabs +
16.06417757920695) * zabs + 86.78073220294608) * zabs +
296.5642487796737) * zabs + 637.3336333788311) * zabs +
793.8265125199484) * zabs + 440.4137358247522);
/* |Z| >= CUTOFF. */
} else {
p = expntl / (zabs + 1 / (zabs + 2 / (zabs + 3 / (zabs + 4 / (
zabs + .65))))) / 2.506628274631001;
}
}
if (*z__ > 0.) {
p = 1 - p;
}
ret_val = p;
RETURN_ARRAYS_DECREMENT();
return ret_val;
} /* cmvphi_ */
