/* Sample from a univariate truncated Normal distribution
(truncated both from above and below): choose either inverse cdf
method or rejection sampling method. For rejection sampling,
if the range is too far from mu, it uses standard rejection
sampling algorithm with exponential envelope function. */
double TruncNorm(
double lb, /* lower bound */
double ub, /* upper bound */
double mu, /* mean */
double var, /* variance */
int invcdf /* use inverse cdf method? */
) {
double z;
double sigma = sqrt(var);
double stlb = (lb-mu)/sigma; /* standardized lower bound */
double stub = (ub-mu)/sigma; /* standardized upper bound */
if(stlb > stub)
error("TruncNorm: lower bound is greater than upper bound\n");
if(stlb == stub) {
warning("TruncNorm: lower bound is equal to upper bound\n");
return(stlb*sigma + mu);
}
if (invcdf) { /* inverse cdf method */
z = qnorm(runif(pnorm(stlb, 0, 1, 1, 0), pnorm(stub, 0, 1, 1, 0)),
0, 1, 1, 0);
}
else { /* rejection sampling method */
double tol=2.0;
double temp, M, u, exp_par;
int flag=0; /* 1 if stlb, stub <-tol */
if(stub<=-tol){
flag=1;
temp=stub;
stub=-stlb;
stlb=-temp;
}
if(stlb>=tol){
exp_par=stlb;
while(pexp(stub,1/exp_par,1,0) - pexp(stlb,1/exp_par,1,0) < 0.000001)
exp_par/=2.0;
if(dnorm(stlb,0,1,1) - dexp(stlb,1/exp_par,1) >=
dnorm(stub,0,1,1) - dexp(stub,1/exp_par,1))
M=exp(dnorm(stlb,0,1,1) - dexp(stlb,1/exp_par,1));
else
M=exp(dnorm(stub,0,1,1) - dexp(stub,1/exp_par,1));
do{
u=unif_rand();
z=-log(1-u*(pexp(stub,1/exp_par,1,0)-pexp(stlb,1/exp_par,1,0))
-pexp(stlb,1/exp_par,1,0))/exp_par;
}while(unif_rand() > exp(dnorm(z,0,1,1)-dexp(z,1/exp_par,1))/M );
if(flag==1) z=-z;
}
else{
do z=norm_rand();
while( z<stlb || z>stub );
}
}
return(z*sigma + mu);
}
Type objective_function<Type>::operator() () {
// data:
DATA_MATRIX(age);
DATA_VECTOR(len);
DATA_SCALAR(CV_e);
DATA_INTEGER(num_reads);
// parameters:
PARAMETER(a); // upper asymptote
PARAMETER(b); // growth range
PARAMETER(k); // growth rate
PARAMETER(CV_Lt);
PARAMETER(beta);
PARAMETER_VECTOR(age_re);
// procedures:
Type n = len.size();
Type nll = 0.0; // Initialize negative log-likelihood
Type eps = 1e-5;
CV_e = CV_e < 0.05 ? 0.05 : CV_e;
for (int i = 0; i < n; i++) {
Type x = age_re(i);
if (!isNA(x) && isFinite(x)) {
Type len_pred = a / (1 + b * exp(-k * x));
Type sigma_e = CV_e * x + eps;
Type sigma_Lt = CV_Lt * (len_pred + eps);
nll -= dnorm(len(i), len_pred, sigma_Lt, true);
nll -= dexp(x, beta, true);
for (int j = 0; j < num_reads; j++) {
if (!isNA(age(j, i)) && isFinite(age(j, i)) && age(j, i) >= 0) {
nll -= dnorm(age(j, i), x, sigma_e, true);
}
}
}
}
return nll;
}
/*
Susceptible-Infectious-Removed MCMC analysis:
. Exponentially distributed infectiousness periods
*/
static void expLikelihood_SIR(double *parameters, double *infectionTimes,
double *removalTimes, int *N, int *nInfected, int *nRemoved,
double *sumSI, double *sumDurationInfectious, double *likelihood,
double *allTimes, int *indicator, int *SS, int *II)
{
int i,k=0,initialInfective=0, nEvents;
double sumLogBeta=0, sumLogInfections=0, sumDurationDensity=0, sumBetaSI=0;
nEvents = *nInfected+*nRemoved;
for(i = 0; i < *nInfected; ++i){
allTimes[(i*2)] = infectionTimes[i];
allTimes[(i*2)+1] = removalTimes[i];
indicator[(i*2)] = 2;
indicator[(i*2)+1] = 1;
if(removalTimes[i]==0){++initialInfective;}
}
rsort_with_index(allTimes,indicator,nEvents);
SS[0] = *N+initialInfective;
II[0] = 0;
for(i = 1; i < (nEvents+1); ++i){
if(indicator[(i-1)] == 2){
SS[i] = SS[(i-1)]-1;
II[i] = II[(i-1)]+1;}
else{
SS[i] = SS[(i-1)];
II[i] = II[(i-1)]-1;}
}
*sumSI = 0;
*sumDurationInfectious = 0;
/*sumLogBeta=(*nInfected-initialInfective)*log(parameters[0]);*/
for(i = 1; i < nEvents; ++i){/* "0" is the start of observation */
if(allTimes[i] != allTimes[i-1]){k = i;}
sumBetaSI+=parameters[0]*II[i]*SS[i]*(allTimes[i]-allTimes[(i-1)]);
if(indicator[i] == 1 && II[k] != 0){sumLogInfections+=log(II[k]);}
if(indicator[i] == 2 && II[k] != 0){sumLogInfections+=log(parameters[0]*SS[k]*II[k]);}
*sumSI+=SS[i]*II[i]*(allTimes[i]-allTimes[(i-1)]);
}
for(i = 0; i < *nRemoved; ++i){
sumDurationDensity+=dexp((removalTimes[i]-infectionTimes[i]),1/parameters[1],TRUE);
*sumDurationInfectious+=(removalTimes[i]-infectionTimes[i]);
}
*likelihood=sumLogBeta+sumLogInfections-sumBetaSI+sumDurationDensity;
}
Type objective_function<Type>::operator() ()
{
DATA_STRING(distr);
DATA_INTEGER(n);
Type ans = 0;
if (distr == "norm") {
PARAMETER(mu);
PARAMETER(sd);
vector<Type> x = rnorm(n, mu, sd);
ans -= dnorm(x, mu, sd, true).sum();
}
else if (distr == "gamma") {
PARAMETER(shape);
PARAMETER(scale);
vector<Type> x = rgamma(n, shape, scale);
ans -= dgamma(x, shape, scale, true).sum();
}
else if (distr == "pois") {
PARAMETER(lambda);
vector<Type> x = rpois(n, lambda);
ans -= dpois(x, lambda, true).sum();
}
else if (distr == "compois") {
PARAMETER(mode);
PARAMETER(nu);
vector<Type> x = rcompois(n, mode, nu);
ans -= dcompois(x, mode, nu, true).sum();
}
else if (distr == "compois2") {
PARAMETER(mean);
PARAMETER(nu);
vector<Type> x = rcompois2(n, mean, nu);
ans -= dcompois2(x, mean, nu, true).sum();
}
else if (distr == "nbinom") {
PARAMETER(size);
PARAMETER(prob);
vector<Type> x = rnbinom(n, size, prob);
ans -= dnbinom(x, size, prob, true).sum();
}
else if (distr == "nbinom2") {
PARAMETER(mu);
PARAMETER(var);
vector<Type> x = rnbinom2(n, mu, var);
ans -= dnbinom2(x, mu, var, true).sum();
}
else if (distr == "exp") {
PARAMETER(rate);
vector<Type> x = rexp(n, rate);
ans -= dexp(x, rate, true).sum();
}
else if (distr == "beta") {
PARAMETER(shape1);
PARAMETER(shape2);
vector<Type> x = rbeta(n, shape1, shape2);
ans -= dbeta(x, shape1, shape2, true).sum();
}
else if (distr == "f") {
PARAMETER(df1);
PARAMETER(df2);
vector<Type> x = rf(n, df1, df2);
ans -= df(x, df1, df2, true).sum();
}
else if (distr == "logis") {
PARAMETER(location);
PARAMETER(scale);
vector<Type> x = rlogis(n, location, scale);
ans -= dlogis(x, location, scale, true).sum();
}
else if (distr == "t") {
PARAMETER(df);
vector<Type> x = rt(n, df);
ans -= dt(x, df, true).sum();
}
else if (distr == "weibull") {
PARAMETER(shape);
PARAMETER(scale);
vector<Type> x = rweibull(n, shape, scale);
ans -= dweibull(x, shape, scale, true).sum();
}
else if (distr == "AR1") {
PARAMETER(phi);
vector<Type> x(n);
density::AR1(phi).simulate(x);
ans += density::AR1(phi)(x);
}
else if (distr == "ARk") {
PARAMETER_VECTOR(phi);
vector<Type> x(n);
density::ARk(phi).simulate(x);
ans += density::ARk(phi)(x);
}
else if (distr == "MVNORM") {
PARAMETER(phi);
matrix<Type> Sigma(5,5);
for(int i=0; i<Sigma.rows(); i++)
for(int j=0; j<Sigma.rows(); j++)
Sigma(i,j) = exp( -phi * abs(i - j) );
density::MVNORM_t<Type> nldens = density::MVNORM(Sigma);
for(int i = 0; i<n; i++) {
vector<Type> x = nldens.simulate();
ans += nldens(x);
}
}
else if (distr == "SEPARABLE") {
PARAMETER(phi1);
PARAMETER_VECTOR(phi2);
array<Type> x(100, 200);
SEPARABLE( density::ARk(phi2), density::AR1(phi1) ).simulate(x);
ans += SEPARABLE( density::ARk(phi2), density::AR1(phi1) )(x);
}
else if (distr == "GMRF") {
PARAMETER(delta);
matrix<Type> Q0(5, 5);
Q0 <<
1,-1, 0, 0, 0,
-1, 2,-1, 0, 0,
0,-1, 2,-1, 0,
0, 0,-1, 2,-1,
0, 0, 0,-1, 1;
Q0.diagonal().array() += delta;
Eigen::SparseMatrix<Type> Q = asSparseMatrix(Q0);
vector<Type> x(5);
for(int i = 0; i<n; i++) {
density::GMRF(Q).simulate(x);
ans += density::GMRF(Q)(x);
}
}
else if (distr == "SEPARABLE_NESTED") {
PARAMETER(phi1);
PARAMETER(phi2);
PARAMETER(delta);
matrix<Type> Q0(5, 5);
Q0 <<
1,-1, 0, 0, 0,
-1, 2,-1, 0, 0,
0,-1, 2,-1, 0,
0, 0,-1, 2,-1,
0, 0, 0,-1, 1;
Q0.diagonal().array() += delta;
Eigen::SparseMatrix<Type> Q = asSparseMatrix(Q0);
array<Type> x(5, 6, 7);
for(int i = 0; i<n; i++) {
SEPARABLE(density::AR1(phi2),
SEPARABLE(density::AR1(phi1),
density::GMRF(Q) ) ).simulate(x);
ans += SEPARABLE(density::AR1(phi2),
SEPARABLE(density::AR1(phi1),
density::GMRF(Q) ) )(x);
}
}
else error( ("Invalid distribution '" + distr + "'").c_str() );
return ans;
}
