#include using namespace Rcpp; // This file contains the following functions: // linpredcompute - computing the linear predictor for covariates. // quadform - computing quadratic forms phi %*% Q %*% theta. // binomialbetaupdateMALA - update regression parameters in the binomial model using MALA // binomialbetaupdateRW - update regression parameters in the binomial model using RW // binomialcarupdateRW - update random effects in the binomial model using RW // binomialindepupdateRW - update the independent effects in the binomial model using RW // poissonbetaupdateMALA - update regression parameters in the poisson model using MALA // poissonbetaupdateRW - update regression parameters in the poisson model using RW // poissoncarupdateRW - update random effects in the poisson model using RW // poissonindepupdateRW - update the independent effects in the poisson model using RW // zipcarupdateRW - update the random effects in the zip models using RW // zipindepupdateRW - update the independent random effects in the zip models using RW // gaussiancarupdate - update random effects in the Gaussian model // binomialmcarupdateRW - update random effects in the binomial MCAR model using RW // poissonmcarupdateRW - update random effects in the poisson MCAR model using RW // gaussianmcarupdateRW - update random effecs in the Gaussian MCAR model usng RW // multinomialbetaupdateRW - update beta in the multinomial model using RW // poissoncarmultilevelupdate - Poisson spatial random effects updates // binomialcarmultilevelupdate - binomial spatial random effects updates // gaussiancarmultilevelupdate - gaussian spatial random effects updates // gaussiancarmultilevelupdateindiv - Gaussian indep random effect updates // poissoncarmultilevelupdateindiv - Poisson indep random effect updates // binomialcarmultilevelupdateindiv - binomial indep random effect updates // basiscomputelinear - Basis function computation for the RAB model with linear basis functions // basiscomputeinv - Basis function computation for the RAB model with inverse basis functions // basiscomputeexp - Basis function computation for the RAB model with exponential basis functions /////////////////////////////////////////////////////////////////////////////// // [[Rcpp::export]] NumericVector linpredcompute(NumericMatrix X, const int nsites, const int p, NumericVector beta, NumericVector offset) { //Create new objects // Compute the linear predictor NumericVector linpred(nsites); double temp; // Compute the linear predictor via a double for loop for(int j = 0; j < nsites; j++) { temp = 0; for(int l = 0; l < p; l++) temp = temp + X(j,l) * beta[l]; linpred[j] = temp + offset[j]; } // Return the result return linpred; } /////////////////////////////////////////////////////////////////////////////// // [[Rcpp::export]] double quadform(NumericMatrix Wtriplet, NumericVector Wtripletsum, const int n_triplet, const int nsites, NumericVector phi, NumericVector theta, double rho) { // Compute a quadratic form for the random effects // Create new objects double tau2_posteriorscale; double tau2_quadform = 0, tau2_phisq = 0; // Compute the off diagonal elements of the quadratic form for(int l = 0; l < n_triplet; l++) { tau2_quadform = tau2_quadform + phi[(Wtriplet(l,0) - 1)] * theta[(Wtriplet(l,1) - 1)] * Wtriplet(l,2); } // Compute the diagonal elements of the quadratic form for(int l = 0; l < nsites; l++) { tau2_phisq = tau2_phisq + phi[l] * theta[l] * (rho * Wtripletsum[l] + 1 - rho); } // Compute the quadratic form tau2_posteriorscale = 0.5 * (tau2_phisq - rho * tau2_quadform); // Return the simulated value return tau2_posteriorscale; } ////////////////////////////////////////////////////////////////////////////// // [[Rcpp::export]] List binomialindepupdateRW(const int nsites, NumericVector theta, double sigma2, const NumericVector y, const NumericVector failures, const double theta_tune, NumericVector offset) { // Update the independent random effects //Create new objects int accept=0; double acceptance; double oldpriorbit, newpriorbit, oldlikebit, newlikebit; double proptheta, pold, pnew; NumericVector thetanew(nsites); // Update each random effect in turn thetanew = theta; for(int j = 0; j < nsites; j++) { // propose a value proptheta = rnorm(1, thetanew[j], theta_tune)[0]; // Accept or reject it // Full conditional ratio newpriorbit = (0.5/sigma2) * pow(proptheta, 2); oldpriorbit = (0.5/sigma2) * pow(thetanew[j], 2); pold = exp(offset[j] + thetanew[j]) / (1 + exp(offset[j] + thetanew[j])); pnew = exp(offset[j] + proptheta) / (1 + exp(offset[j] + proptheta)); oldlikebit = y[j] * log(pold) + failures[j] * log((1-pold)); newlikebit = y[j] * log(pnew) + failures[j] * log((1-pnew)); acceptance = exp(oldpriorbit - newpriorbit - oldlikebit + newlikebit); // Acceptace or reject the proposal if(runif(1)[0] <= acceptance) { thetanew[j] = proptheta; accept = accept + 1; } else { } } List out(2); out[0] = thetanew; out[1] = accept; return out; } /////////////////////////////////////////////////////////////////////////////// // [[Rcpp::export]] List binomialcarupdateRW(NumericMatrix Wtriplet, NumericMatrix Wbegfin, NumericVector Wtripletsum,const int nsites, NumericVector phi, double tau2, const NumericVector y, const NumericVector failures, const double phi_tune, double rho, NumericVector offset) { // Update the spatially correlated random effects //Create new objects int accept=0, rowstart=0, rowend=0; double acceptance, sumphi; double oldpriorbit, newpriorbit, oldlikebit, newlikebit; double priorvardenom, priormean, priorvar; double propphi, pold, pnew, proposal_var; NumericVector phinew(nsites); // Update each random effect in turn phinew = phi; for(int j = 0; j < nsites; j++) { // Calculate prior variance priorvardenom = rho * Wtripletsum[j] + 1 - rho; priorvar = tau2 / priorvardenom; // Calculate the prior mean rowstart = Wbegfin(j,0) - 1; rowend = Wbegfin(j,1); sumphi = 0; for(int l = rowstart; l < rowend; l++) sumphi += Wtriplet(l, 2) * phinew[(Wtriplet(l,1) - 1)]; priormean = rho * sumphi / priorvardenom; // propose a value proposal_var = priorvar * phi_tune; propphi = rnorm(1, phinew[j], sqrt(proposal_var))[0]; // Accept or reject it // Full conditional ratio newpriorbit = (0.5/priorvar) * pow((propphi - priormean), 2); oldpriorbit = (0.5/priorvar) * pow((phinew[j] - priormean), 2); pold = exp(offset[j] + phinew[j]) / (1 + exp(offset[j] + phinew[j])); pnew = exp(offset[j] + propphi) / (1 + exp(offset[j] + propphi)); oldlikebit = y[j] * log(pold) + failures[j] * log((1-pold)); newlikebit = y[j] * log(pnew) + failures[j] * log((1-pnew)); acceptance = exp(oldpriorbit - newpriorbit - oldlikebit + newlikebit); // Acceptace or reject the proposal if(runif(1)[0] <= acceptance) { phinew[j] = propphi; accept = accept + 1; } else { } } // Return the results List out(2); out[0] = phinew; out[1] = accept; return out; } ////////////////////////////////////////////////////////////////////////////// // [[Rcpp::export]] List binomialbetaupdateRW(NumericMatrix X, const int nsites, const int p, NumericVector beta, NumericVector offset, NumericVector y, NumericVector failures, NumericVector prior_meanbeta, NumericVector prior_varbeta, const int nblock,double beta_tune, List block_list) { // Compute the acceptance probability for beta //Create new objects int accept=0; double oldlikebit=0, newlikebit=0, likebit, priorbit=0; double acceptance; NumericVector lp_current(nsites), lp_proposal(nsites), p_current(nsites), p_proposal(nsites); // Create two beta vectors NumericVector beta_old(p); NumericVector beta_new(p); for(int g=0; g