//[[Rcpp::export]]
List gp_gdp(vec y, mat X, mat cand_S, vec init, vec priors, int B, int burn, bool printProg) {
int n = y.size();
int num_params = cand_S.n_rows;
mat In = eye<mat>(n,n);
int acc_rate = 0;
mat param = zeros<mat>(B+burn,num_params);
double log_ratio;
vec cand = zeros<vec>(num_params);
vec curr = zeros<vec>(num_params);
List ret;
clock_t start_time = clock();
int freq = 50;
param.row(0) = reshape(init,1,num_params);
Rcout << endl;
for (int b=1; b<B+burn; b++) {
// Update s2, phi, tau:
curr = vectorise(param.row(b-1));
cand = mvrnorm(curr, cand_S); // s2, phi, tau, d1,...,dp
log_ratio = log_like_plus_log_prior(y,X,cand,In,priors) -
log_like_plus_log_prior(y,X,curr,In,priors);
if ( log_ratio > log(randu()) ) {
param.row(b) = reshape(cand,1,num_params);
if (b > burn) acc_rate++;
} else {
param.row(b) = param.row(b-1);
}
if (printProg) time_remain(start_time, b, B+burn-1, freq);
if (b % freq == 0) start_time = clock();
}
Rcout << endl;
param.col(0) = exp(param.col(0));
param.col(1) = (priors[3]*exp(param.col(1))+priors[2]) / ( exp(param.col(1))+1 );// inverse logit
param.col(2) = exp(param.col(2));
Rcout <<"Acceptance Rate: " << acc_rate * 1.0 / B << endl;
Rcout <<"The parameters in $param are 's2,phi,tau'" << endl;
ret["param"] = param.tail_rows(B); //s2, phi, tau
ret["acc_rate"] = acc_rate * 1.0 / B;
ret["y"] = y;
ret["X"] = X;
ret["cand_S"] = cand_S;
return ret;
}
//[[Rcpp::export]]
mat one_pred_gp_gdp(mat X, vec y, mat param_row) {
vec param = vectorise(param_row);
double s2 = param[0];
double phi = param[1];
double tau = param[2];
vec d = param.tail(param.size()-3);
int n = X.n_rows;
mat XdX = xDx(X,d % d);
mat K = tau * exp(-phi*XdX);
mat Xt = X.t();
mat I = eye(n,n);
mat S_i = (K.i() + I / s2).i();
vec mu = S_i*y / s2;
vec pred_y = mvrnorm(mu,S_i);
return reshape(pred_y,1,n);
}
SEXP spPPLM(SEXP Y_r, SEXP X_r, SEXP p_r, SEXP n_r, SEXP m_r, SEXP knotsD_r, SEXP knotsCoordsD_r,
SEXP modPP_r, SEXP betaPrior_r, SEXP betaNorm_r, SEXP sigmaSqIG_r, SEXP tauSqIG_r, SEXP nuUnif_r, SEXP phiUnif_r,
SEXP betaStarting_r, SEXP phiStarting_r, SEXP sigmaSqStarting_r, SEXP tauSqStarting_r, SEXP nuStarting_r,
SEXP phiTuning_r, SEXP sigmaSqTuning_r, SEXP tauSqTuning_r, SEXP nuTuning_r,
SEXP nugget_r, SEXP covModel_r, SEXP amcmc_r, SEXP nBatch_r, SEXP batchLength_r, SEXP acceptRate_r, SEXP verbose_r, SEXP nReport_r){
/*****************************************
Common variables
*****************************************/
int i, j, k, l, b, s, info, nProtect=0;
char const *lower = "L";
char const *upper = "U";
char const *nUnit = "N";
char const *yUnit = "U";
char const *ntran = "N";
char const *ytran = "T";
char const *rside = "R";
char const *lside = "L";
const double one = 1.0;
const double negOne = -1.0;
const double zero = 0.0;
const int incOne = 1;
/*****************************************
Set-up
*****************************************/
double *Y = REAL(Y_r);
double *X = REAL(X_r);
int p = INTEGER(p_r)[0];
int pp = p*p;
int n = INTEGER(n_r)[0];
int nn = n*n;
int np = n*p;
int m = INTEGER(m_r)[0];
int nm = n*m;
int mm = m*m;
int mp = m*p;
double *knotsD = REAL(knotsD_r);
double *knotsCoordsD = REAL(knotsCoordsD_r);
bool modPP = static_cast<bool>(INTEGER(modPP_r)[0]);
std::string covModel = CHAR(STRING_ELT(covModel_r,0));
//priors
std::string betaPrior = CHAR(STRING_ELT(betaPrior_r,0));
double *betaMu = NULL;
double *betaC = NULL;
if(betaPrior == "normal"){
betaMu = (double *) R_alloc(p, sizeof(double));
F77_NAME(dcopy)(&p, REAL(VECTOR_ELT(betaNorm_r, 0)), &incOne, betaMu, &incOne);
betaC = (double *) R_alloc(pp, sizeof(double));
F77_NAME(dcopy)(&pp, REAL(VECTOR_ELT(betaNorm_r, 1)), &incOne, betaC, &incOne);
}
double sigmaSqIGa = REAL(sigmaSqIG_r)[0]; double sigmaSqIGb = REAL(sigmaSqIG_r)[1];
double phiUnifa = REAL(phiUnif_r)[0]; double phiUnifb = REAL(phiUnif_r)[1];
bool nugget = static_cast<bool>(INTEGER(nugget_r)[0]);
double tauSqIGa = 0, tauSqIGb = 0;
if(nugget){
tauSqIGa = REAL(tauSqIG_r)[0]; tauSqIGb = REAL(tauSqIG_r)[1];
}
//matern
double nuUnifa = 0, nuUnifb = 0;
if(covModel == "matern"){
nuUnifa = REAL(nuUnif_r)[0]; nuUnifb = REAL(nuUnif_r)[1];
}
bool amcmc = static_cast<bool>(INTEGER(amcmc_r)[0]);
int nBatch = INTEGER(nBatch_r)[0];
int batchLength = INTEGER(batchLength_r)[0];
double acceptRate = REAL(acceptRate_r)[0];
int nSamples = nBatch*batchLength;
int verbose = INTEGER(verbose_r)[0];
int nReport = INTEGER(nReport_r)[0];
if(verbose){
Rprintf("----------------------------------------\n");
Rprintf("\tGeneral model description\n");
Rprintf("----------------------------------------\n");
Rprintf("Model fit with %i observations.\n\n", n);
Rprintf("Number of covariates %i (including intercept if specified).\n\n", p);
Rprintf("Using the %s spatial correlation model.\n\n", covModel.c_str());
if(modPP){
Rprintf("Using modified predictive process with %i knots.\n\n", m);
}else{
Rprintf("Using non-modified predictive process with %i knots.\n\n", m);
}
if(amcmc){
Rprintf("Using adaptive MCMC.\n\n");
Rprintf("\tNumber of batches %i.\n", nBatch);
Rprintf("\tBatch length %i.\n", batchLength);
Rprintf("\tTarget acceptance rate %.5f.\n", acceptRate);
Rprintf("\n");
}else{
Rprintf("Number of MCMC samples %i.\n\n", nSamples);
}
if(!nugget){
Rprintf("tau.sq not included in the model (i.e., no nugget model).\n\n");
}
Rprintf("Priors and hyperpriors:\n");
if(betaPrior == "flat"){
Rprintf("\tbeta flat.\n");
}else{
Rprintf("\tbeta normal:\n");
Rprintf("\tmu:"); printVec(betaMu, p);
Rprintf("\tcov:\n"); printMtrx(betaC, p, p);
Rprintf("\n");
}
Rprintf("\tsigma.sq IG hyperpriors shape=%.5f and scale=%.5f\n", sigmaSqIGa, sigmaSqIGb);
if(nugget){
Rprintf("\ttau.sq IG hyperpriors shape=%.5f and scale=%.5f\n", tauSqIGa, tauSqIGb);
}
Rprintf("\tphi Unif hyperpriors a=%.5f and b=%.5f\n", phiUnifa, phiUnifb);
if(covModel == "matern"){
Rprintf("\tnu Unif hyperpriors a=%.5f and b=%.5f\n", nuUnifa, nuUnifb);
}
}
/*****************************************
Set-up MCMC sample matrices etc.
*****************************************/
//parameters
int nParams, sigmaSqIndx, tauSqIndx, phiIndx, nuIndx;
if(!nugget && covModel != "matern"){
nParams = 2;//sigma^2, phi
sigmaSqIndx = 0; phiIndx = 1;
}else if(nugget && covModel != "matern"){
nParams = 3;//sigma^2, tau^2, phi
sigmaSqIndx = 0; tauSqIndx = 1; phiIndx = 2;
}else if(!nugget && covModel == "matern"){
nParams = 3;//sigma^2, phi, nu
sigmaSqIndx = 0; phiIndx = 1; nuIndx = 2;
}else{
nParams = 4;//sigma^2, tau^2, phi, nu
sigmaSqIndx = 0; tauSqIndx = 1; phiIndx = 2; nuIndx = 3;//sigma^2, tau^2, phi, nu
}
double *params = (double *) R_alloc(nParams, sizeof(double));
//starting
double *beta = (double *) R_alloc(p, sizeof(double));
F77_NAME(dcopy)(&p, REAL(betaStarting_r), &incOne, beta, &incOne);
params[sigmaSqIndx] = log(REAL(sigmaSqStarting_r)[0]);
if(nugget){
params[tauSqIndx] = log(REAL(tauSqStarting_r)[0]);
}
params[phiIndx] = logit(REAL(phiStarting_r)[0], phiUnifa, phiUnifb);
if(covModel == "matern"){
params[nuIndx] = logit(REAL(nuStarting_r)[0], nuUnifa, nuUnifb);
}
//tuning and fixed
double *tuning = (double *) R_alloc(nParams, sizeof(double));
int *fixed = (int *) R_alloc(nParams, sizeof(int)); zeros(fixed, nParams);
tuning[sigmaSqIndx] = REAL(sigmaSqTuning_r)[0];
if(tuning[sigmaSqIndx] == 0){
fixed[sigmaSqIndx] = 1;
}
if(nugget){
tuning[tauSqIndx] = REAL(tauSqTuning_r)[0];
if(tuning[tauSqIndx] == 0){
fixed[tauSqIndx] = 1;
}
}
tuning[phiIndx] = REAL(phiTuning_r)[0];
if(tuning[phiIndx] == 0){
fixed[phiIndx] = 1;
}
if(covModel == "matern"){
tuning[nuIndx] = REAL(nuTuning_r)[0];
if(tuning[nuIndx] == 0){
fixed[nuIndx] = 1;
}
}
for(i = 0; i < nParams; i++){
tuning[i] = log(sqrt(tuning[i]));
}
//return stuff
SEXP samples_r, accept_r, tuning_r, betaSamples_r;
PROTECT(samples_r = allocMatrix(REALSXP, nParams, nSamples)); nProtect++;
PROTECT(accept_r = allocMatrix(REALSXP, nParams, nBatch)); nProtect++;
PROTECT(tuning_r = allocMatrix(REALSXP, nParams, nBatch)); nProtect++;
PROTECT(betaSamples_r = allocMatrix(REALSXP, p, nSamples)); nProtect++;
/*****************************************
Set-up MCMC alg. vars. matrices etc.
*****************************************/
int status=1, batchAccept=0;
double logMHRatio =0, logPostCurrent = R_NegInf, logPostCand = 0, paramsjCurrent = 0;
double det = 0, detCurrent = 0;
double priors = 0, priorsCurrent = 0;
bool updateBeta = false;
double *paramsCurrent = (double *) R_alloc(nParams, sizeof(double));
double *accept = (double *) R_alloc(nParams, sizeof(double)); zeros(accept, nParams);
double *P = (double *) R_alloc(nm, sizeof(double));
double *K = (double *) R_alloc(mm, sizeof(double));
double *D = (double *) R_alloc(n, sizeof(double));
double *H = (double *) R_alloc(nm, sizeof(double));
double *u = (double *) R_alloc(n, sizeof(double));
F77_NAME(dgemv)(ntran, &n, &p, &negOne, X, &n, beta, &incOne, &zero, u, &incOne);
F77_NAME(daxpy)(&n, &one, Y, &incOne, u, &incOne);
double *DCurrent = (double *) R_alloc(n, sizeof(double));
double *HCurrent = (double *) R_alloc(nm, sizeof(double));
double sigmaSq, phi, tauSq, nu, Q;
double *theta = (double *) R_alloc(3, sizeof(double)); //phi, nu, and perhaps more in the future
double *tmp_n = (double *) R_alloc(n, sizeof(double));
double *tmp_np = (double *) R_alloc(np, sizeof(double));
double *tmp_mm = (double *) R_alloc(mm, sizeof(double));
double *tmp_mp = (double *) R_alloc(mp, sizeof(double));
double *tmp_pp = (double *) R_alloc(pp, sizeof(double));
double *tmp_pp2 = (double *) R_alloc(pp, sizeof(double));
double *tmp_p = (double *) R_alloc(p, sizeof(double));
double *tmp_p2 = (double *) R_alloc(p, sizeof(double));
double *tmp_m = (double *) R_alloc(m, sizeof(double));
double *betaCInv = NULL;
double *betaCInvMu = NULL;
if(betaPrior == "normal"){
betaCInv = (double *) R_alloc(pp, sizeof(double));
betaCInvMu = (double *) R_alloc(p, sizeof(double));
F77_NAME(dcopy)(&pp, betaC, &incOne, betaCInv, &incOne);
F77_NAME(dpotrf)(lower, &p, betaCInv, &p, &info); if(info != 0){error("c++ error: dpotrf failed\n");}
F77_NAME(dpotri)(lower, &p, betaCInv, &p, &info); if(info != 0){error("c++ error: dpotri failed\n");}
F77_NAME(dsymv)(lower, &p, &one, betaCInv, &p, betaMu, &incOne, &zero, betaCInvMu, &incOne);
}
if(verbose){
Rprintf("-------------------------------------------------\n");
Rprintf("\t\tSampling\n");
Rprintf("-------------------------------------------------\n");
#ifdef Win32
R_FlushConsole();
#endif
}
GetRNGstate();
for(b = 0, s = 0; b < nBatch; b++){
for(i = 0; i < batchLength; i++, s++){
for(j = 0; j < nParams; j++){
//propose
if(amcmc){
if(fixed[j] == 1){
paramsjCurrent = params[j];
}else{
paramsjCurrent = params[j];
params[j] = rnorm(paramsjCurrent, exp(tuning[j]));
}
}else{
F77_NAME(dcopy)(&nParams, params, &incOne, paramsCurrent, &incOne);
for(j = 0; j < nParams; j++){
if(fixed[j] == 1){
params[j] = params[j];
}else{
params[j] = rnorm(params[j], exp(tuning[j]));
}
}
}
//extract and transform
sigmaSq = theta[0] = exp(params[sigmaSqIndx]);
phi = theta[1] = logitInv(params[phiIndx], phiUnifa, phiUnifb);
if(nugget){
tauSq = exp(params[tauSqIndx]);
}
if(covModel == "matern"){
nu = theta[2] = logitInv(params[nuIndx], nuUnifa, nuUnifb);
}
//construct covariance matrices
spCovLT(knotsD, m, theta, covModel, K);
spCov(knotsCoordsD, nm, theta, covModel, P);
//get D
if(modPP){
for(k = 0; k < m; k++){
for(l = k; l < m; l++){
tmp_mm[k*m+l] = K[k*m+l];
}
}
F77_NAME(dpotrf)(lower, &m, tmp_mm, &m, &info); if(info != 0){error("c++ error: dpotrf failed\n");}//L_K
F77_NAME(dcopy)(&nm, P, &incOne, H, &incOne);
F77_NAME(dtrsm)(lside, lower, ntran, nUnit, &m, &n, &one, tmp_mm, &m, H, &m);
for(k = 0; k < n; k++){
D[k] = sigmaSq - F77_NAME(ddot)(&m, &H[k*m], &incOne, &H[k*m], &incOne);
if(nugget){
D[k] += tauSq;
}
}
}else{
for(k = 0; k < n; k++){
D[k] = tauSq;
}
}
for(k = 0; k < n; k++){
for(l = 0; l < m; l++){
H[k*m+l] = P[k*m+l]/sqrt(D[k]);//W'
}
}
F77_NAME(dgemm)(ntran, ytran, &m, &m, &n, &one, H, &m, H, &m, &zero, tmp_mm, &m);//W'W
for(k = 0; k < m; k++){
for(l = k; l < m; l++){
K[k*m+l] += tmp_mm[k*m+l];
}
}
F77_NAME(dpotrf)(lower, &m, K, &m, &info); if(info != 0){error("c++ error: dpotrf failed\n");}//L
F77_NAME(dtrsm)(lside, lower, ntran, nUnit, &m, &n, &one, K, &m, H, &m);//LH = W'
for(k = 0; k < n; k++){
tmp_n[k] = u[k]/sqrt(D[k]);//v
}
F77_NAME(dgemv)(ntran, &m, &n, &one, H, &m, tmp_n, &incOne, &zero, tmp_m, &incOne); //w = Hv
Q = F77_NAME(ddot)(&n, tmp_n, &incOne, tmp_n, &incOne) - F77_NAME(ddot)(&m, tmp_m, &incOne, tmp_m, &incOne);
F77_NAME(dgemm)(ntran, ytran, &m, &m, &n, &negOne, H, &m, H, &m, &zero, tmp_mm, &m);//-HH'
for(k = 0; k < m; k++){
tmp_mm[k*m+k] += 1.0; //J
}
F77_NAME(dpotrf)(lower, &m, tmp_mm, &m, &info); if(info != 0){error("c++ error: dpotrf failed\n");}//L_J
det = 0;
for(k = 0; k < n; k++){
det += log(D[k]);
}
for(k = 0; k < m; k++){
det -= 2*log(tmp_mm[k*m+k]);
}
//Priors, jacobian adjustments, and likelihood
priors = -1.0*(1.0+sigmaSqIGa)*log(sigmaSq)-sigmaSqIGb/sigmaSq+log(sigmaSq);
if(nugget){
priors += -1.0*(1.0+tauSqIGa)*log(tauSq)-tauSqIGb/tauSq+log(tauSq);
}
priors += log(phi - phiUnifa) + log(phiUnifb - phi);
if(covModel == "matern"){
priors += log(nu - nuUnifa) + log(nuUnifb - nu);
}
logPostCand = priors-0.5*det-0.5*Q;
//
//MH accept/reject
//
logMHRatio = logPostCand - logPostCurrent;
if(runif(0.0,1.0) <= exp(logMHRatio)){
logPostCurrent = logPostCand;
F77_NAME(dcopy)(&n, D, &incOne, DCurrent, &incOne);
F77_NAME(dcopy)(&nm, H, &incOne, HCurrent, &incOne);
detCurrent = det;
priorsCurrent = priors;
//set to true so beta's mu and var are updated
updateBeta = true;
if(amcmc){
accept[j]++;
}else{
accept[0]++;
batchAccept++;
}
}else{
if(amcmc){
params[j] = paramsjCurrent;
}else{
F77_NAME(dcopy)(&nParams, paramsCurrent, &incOne, params, &incOne);
}
}
if(!amcmc){
break;
}
}//end params
//only update beta's mu and var if theta has changed
if(updateBeta){
for(k = 0; k < n; k++){
tmp_n[k] = Y[k]/sqrt(DCurrent[k]);//\tilda{y}
for(l = 0; l < p; l++){
tmp_np[l*n+k] = X[l*n+k]/sqrt(DCurrent[k]);//V
}
}
F77_NAME(dgemm)(ntran, ntran, &m, &p, &n, &one, HCurrent, &m, tmp_np, &n, &zero, tmp_mp, &m);//\tilda{V}
F77_NAME(dgemm)(ytran, ntran, &p, &p, &n, &one, tmp_np, &n, tmp_np, &n, &zero, tmp_pp, &p);//V'V
F77_NAME(dgemm)(ytran, ntran, &p, &p, &m, &one, tmp_mp, &m, tmp_mp, &m, &zero, tmp_pp2, &p);//\tilda{V}'\tilda{V}
for(k = 0; k < p; k++){
for(l = k; l < p; l++){
tmp_pp[k*p+l] -= tmp_pp2[k*p+l];//Z
if(betaPrior == "normal"){
tmp_pp[k*p+l] += betaCInv[k*p+l];
}
}
}
//B
F77_NAME(dpotrf)(lower, &p, tmp_pp, &p, &info); if(info != 0){error("c++ error: Cholesky failed\n");}
F77_NAME(dpotri)(lower, &p, tmp_pp, &p, &info); if(info != 0){error("c++ error: Cholesky inverse failed\n");}
//b
F77_NAME(dgemv)(ytran, &n, &p, &one, tmp_np, &n, tmp_n, &incOne, &zero, tmp_p, &incOne); //V'\tilda{y}
F77_NAME(dgemv)(ntran, &m, &n, &one, HCurrent, &m, tmp_n, &incOne, &zero, tmp_m, &incOne); //H\tilda{y}
F77_NAME(dgemv)(ytran, &m, &p, &one, tmp_mp, &m, tmp_m, &incOne, &zero, tmp_pp2, &incOne); //\tilda{V}'(H\tilda{y})
for(k = 0; k < p; k++){
tmp_p[k] -= tmp_pp2[k];
if(betaPrior == "normal"){
tmp_p[k] += betaCInvMu[k];
}
}
F77_NAME(dsymv)(lower, &p, &one, tmp_pp, &p, tmp_p, &incOne, &zero, tmp_p2, &incOne); //Bb
F77_NAME(dpotrf)(lower, &p, tmp_pp, &p, &info); if(info != 0){error("c++ error: dpotrf failed\n");}
}//end updateBeta
//set to false so beta's mu and var are only updated when theta has changed
updateBeta = false;
//draw beta
mvrnorm(beta, tmp_p2, tmp_pp, p, false);//note, tmp_p2 and tmp_pp will carry over when theta is not updated
//update logPostCurrent (beta changes on every iteration so logPostCurrent must be updated)
F77_NAME(dgemv)(ntran, &n, &p, &negOne, X, &n, beta, &incOne, &zero, u, &incOne);
F77_NAME(daxpy)(&n, &one, Y, &incOne, u, &incOne);//u
for(k = 0; k < n; k++){
tmp_n[k] = u[k]/sqrt(DCurrent[k]);//v
}
F77_NAME(dgemv)(ntran, &m, &n, &one, HCurrent, &m, tmp_n, &incOne, &zero, tmp_m, &incOne); //w = Hv
Q = F77_NAME(ddot)(&n, tmp_n, &incOne, tmp_n, &incOne) - F77_NAME(ddot)(&m, tmp_m, &incOne, tmp_m, &incOne);
logPostCurrent = priorsCurrent-0.5*detCurrent-0.5*Q;
/******************************
Save samples
*******************************/
F77_NAME(dcopy)(&p, beta, &incOne, &REAL(betaSamples_r)[s*p], &incOne);
F77_NAME(dcopy)(&nParams, params, &incOne, &REAL(samples_r)[s*nParams], &incOne);
R_CheckUserInterrupt();
}//end batch
//adjust tuning
if(amcmc){
for(j = 0; j < nParams; j++){
REAL(accept_r)[b*nParams+j] = accept[j]/batchLength;
REAL(tuning_r)[b*nParams+j] = tuning[j];
if(accept[j]/batchLength > acceptRate){
tuning[j] += std::min(0.01, 1.0/sqrt(static_cast<double>(b)));
}else{
tuning[j] -= std::min(0.01, 1.0/sqrt(static_cast<double>(b)));
}
accept[j] = 0.0;
}
}
//report
if(verbose){
if(status == nReport){
if(amcmc){
Rprintf("Batch: %i of %i, %3.2f%%\n", b+1, nBatch, 100.0*(b+1)/nBatch);
Rprintf("\tparameter\tacceptance\ttuning\n");
Rprintf("\tsigma.sq\t%3.1f%\t\t%1.5f\n", 100.0*REAL(accept_r)[b*nParams+sigmaSqIndx], exp(tuning[sigmaSqIndx]));
if(nugget){
Rprintf("\ttau.sq\t\t%3.1f%\t\t%1.5f\n", 100.0*REAL(accept_r)[b*nParams+tauSqIndx], exp(tuning[tauSqIndx]));
}
Rprintf("\tphi\t\t%3.1f%\t\t%1.5f\n", 100.0*REAL(accept_r)[b*nParams+phiIndx], exp(tuning[phiIndx]));
if(covModel == "matern"){
Rprintf("\tnu\t\t%3.1f%\t\t%1.5f\n", 100.0*REAL(accept_r)[b*nParams+nuIndx], exp(tuning[nuIndx]));
}
}else{
Rprintf("Sampled: %i of %i, %3.2f%%\n", s, nSamples, 100.0*s/nSamples);
Rprintf("Report interval Metrop. Acceptance rate: %3.2f%%\n", 100.0*batchAccept/nReport);
Rprintf("Overall Metrop. Acceptance rate: %3.2f%%\n", 100.0*accept[0]/s);
}
Rprintf("-------------------------------------------------\n");
#ifdef Win32
R_FlushConsole();
#endif
status = 0;
batchAccept = 0;
}
}
status++;
}//end sample loop
PutRNGstate();
//untransform variance variables
for(s = 0; s < nSamples; s++){
REAL(samples_r)[s*nParams+sigmaSqIndx] = exp(REAL(samples_r)[s*nParams+sigmaSqIndx]);
if(nugget){
REAL(samples_r)[s*nParams+tauSqIndx] = exp(REAL(samples_r)[s*nParams+tauSqIndx]);
}
REAL(samples_r)[s*nParams+phiIndx] = logitInv(REAL(samples_r)[s*nParams+phiIndx], phiUnifa, phiUnifb);
if(covModel == "matern")
REAL(samples_r)[s*nParams+nuIndx] = logitInv(REAL(samples_r)[s*nParams+nuIndx], nuUnifa, nuUnifb);
}
//make return object
SEXP result_r, resultName_r;
int nResultListObjs = 4;
PROTECT(result_r = allocVector(VECSXP, nResultListObjs)); nProtect++;
PROTECT(resultName_r = allocVector(VECSXP, nResultListObjs)); nProtect++;
//samples
SET_VECTOR_ELT(result_r, 0, samples_r);
SET_VECTOR_ELT(resultName_r, 0, mkChar("p.theta.samples"));
SET_VECTOR_ELT(result_r, 1, accept_r);
SET_VECTOR_ELT(resultName_r, 1, mkChar("acceptance"));
SET_VECTOR_ELT(result_r, 2, tuning_r);
SET_VECTOR_ELT(resultName_r, 2, mkChar("tuning"));
SET_VECTOR_ELT(result_r, 3, betaSamples_r);
SET_VECTOR_ELT(resultName_r, 3, mkChar("p.beta.samples"));
namesgets(result_r, resultName_r);
//unprotect
UNPROTECT(nProtect);
return(result_r);
}
SEXP spPPGLM(SEXP Y_r, SEXP X_r, SEXP p_r, SEXP n_r, SEXP family_r, SEXP weights_r,
SEXP m_r, SEXP knotsD_r, SEXP knotsCoordsD_r,
SEXP betaPrior_r, SEXP betaNorm_r, SEXP sigmaSqIG_r, SEXP nuUnif_r, SEXP phiUnif_r,
SEXP phiStarting_r, SEXP sigmaSqStarting_r, SEXP nuStarting_r, SEXP betaStarting_r, SEXP w_strStarting_r,
SEXP phiTuning_r, SEXP sigmaSqTuning_r, SEXP nuTuning_r, SEXP betaTuning_r, SEXP w_strTuning_r,
SEXP covModel_r, SEXP nSamples_r, SEXP verbose_r, SEXP nReport_r){
/*****************************************
Common variables
*****************************************/
int i,j,k,l,info,nProtect= 0;
char const *lower = "L";
char const *upper = "U";
char const *ntran = "N";
char const *ytran = "T";
char const *rside = "R";
char const *lside = "L";
const double one = 1.0;
const double negOne = -1.0;
const double zero = 0.0;
const int incOne = 1;
/*****************************************
Set-up
*****************************************/
double *Y = REAL(Y_r);
double *X = REAL(X_r);
int p = INTEGER(p_r)[0];
int pp = p*p;
int n = INTEGER(n_r)[0];
std::string family = CHAR(STRING_ELT(family_r,0));
int *weights = INTEGER(weights_r);
//covariance model
std::string covModel = CHAR(STRING_ELT(covModel_r,0));
int m = INTEGER(m_r)[0];
double *knotsD = REAL(knotsD_r);
double *knotsCoordsD = REAL(knotsCoordsD_r);
//priors and starting
std::string betaPrior = CHAR(STRING_ELT(betaPrior_r,0));
double *betaMu = NULL;
double *betaSd = NULL;
if(betaPrior == "normal"){
betaMu = REAL(VECTOR_ELT(betaNorm_r, 0));
betaSd = REAL(VECTOR_ELT(betaNorm_r, 1));
}
double *sigmaSqIG = REAL(sigmaSqIG_r);
double *phiUnif = REAL(phiUnif_r);
double phiStarting = REAL(phiStarting_r)[0];
double sigmaSqStarting = REAL(sigmaSqStarting_r)[0];
double *betaStarting = REAL(betaStarting_r);
double *w_strStarting = REAL(w_strStarting_r);
double sigmaSqIGa = sigmaSqIG[0]; double sigmaSqIGb = sigmaSqIG[1];
double phiUnifa = phiUnif[0]; double phiUnifb = phiUnif[1];
//if matern
double *nuUnif = NULL;
double nuStarting = 0;
double nuUnifa = 0, nuUnifb = 0;
if(covModel == "matern"){
nuUnif = REAL(nuUnif_r);
nuStarting = REAL(nuStarting_r)[0];
nuUnifa = nuUnif[0]; nuUnifb = nuUnif[1];
}
//tuning
double *betaTuning = (double *) R_alloc(p*p, sizeof(double));
F77_NAME(dcopy)(&pp, REAL(betaTuning_r), &incOne, betaTuning, &incOne);
double phiTuning = sqrt(REAL(phiTuning_r)[0]);
double sigmaSqTuning = sqrt(REAL(sigmaSqTuning_r)[0]);
double *w_strTuning = REAL(w_strTuning_r);
double nuTuning = 0;
if(covModel == "matern")
nuTuning = sqrt(REAL(nuTuning_r)[0]);
int nSamples = INTEGER(nSamples_r)[0];
int verbose = INTEGER(verbose_r)[0];
int nReport = INTEGER(nReport_r)[0];
if(verbose){
Rprintf("----------------------------------------\n");
Rprintf("\tGeneral model description\n");
Rprintf("----------------------------------------\n");
Rprintf("Model fit with %i observations.\n\n", n);
Rprintf("Number of covariates %i (including intercept if specified).\n\n", p);
Rprintf("Using the %s spatial correlation model.\n\n", covModel.c_str());
Rprintf("Using non-modified predictive process with %i knots.\n\n", m);
Rprintf("Number of MCMC samples %i.\n\n", nSamples);
Rprintf("Priors and hyperpriors:\n");
if(betaPrior == "flat"){
Rprintf("\tbeta flat.\n");
}else{
Rprintf("\tbeta normal:\n");
Rprintf("\t\tmu:"); printVec(betaMu, p);
Rprintf("\t\tsd:"); printVec(betaSd, p);Rprintf("\n");
}
Rprintf("\n");
Rprintf("\tsigma.sq IG hyperpriors shape=%.5f and scale=%.5f\n", sigmaSqIGa, sigmaSqIGb);
Rprintf("\n");
Rprintf("\tphi Unif hyperpriors a=%.5f and b=%.5f\n", phiUnifa, phiUnifb);
Rprintf("\n");
if(covModel == "matern"){
Rprintf("\tnu Unif hyperpriors a=%.5f and b=%.5f\n", nuUnifa, nuUnifb);
}
Rprintf("Metropolis tuning values:\n");
Rprintf("\tbeta tuning:\n");
printMtrx(betaTuning, p, p);
Rprintf("\n");
Rprintf("\tsigma.sq tuning: %.5f\n", sigmaSqTuning);
Rprintf("\n");
Rprintf("\tphi tuning: %.5f\n", phiTuning);
Rprintf("\n");
if(covModel == "matern"){
Rprintf("\tnu tuning: %.5f\n", nuTuning);
Rprintf("\n");
}
Rprintf("Metropolis starting values:\n");
Rprintf("\tbeta starting:\n");
Rprintf("\t"); printVec(betaStarting, p);
Rprintf("\n");
Rprintf("\tsigma.sq starting: %.5f\n", sigmaSqStarting);
Rprintf("\n");
Rprintf("\tphi starting: %.5f\n", phiStarting);
Rprintf("\n");
if(covModel == "matern"){
Rprintf("\tnu starting: %.5f\n", nuStarting);
Rprintf("\n");
}
}
/*****************************************
Set-up MCMC sample matrices etc.
*****************************************/
int nn = n*n, nm = n*m, mm = m*m;
//spatial parameters
int nParams, betaIndx, sigmaSqIndx, phiIndx, nuIndx;
if(covModel != "matern"){
nParams = p+2;//sigma^2, phi
betaIndx = 0; sigmaSqIndx = betaIndx+p; phiIndx = sigmaSqIndx+1;
}else{
nParams = p+3;//sigma^2, phi, nu
betaIndx = 0; sigmaSqIndx = betaIndx+p; phiIndx = sigmaSqIndx+1; nuIndx = phiIndx+1;
}
double *spParams = (double *) R_alloc(nParams, sizeof(double));
//set starting
F77_NAME(dcopy)(&p, betaStarting, &incOne, &spParams[betaIndx], &incOne);
spParams[sigmaSqIndx] = log(sigmaSqStarting);
spParams[phiIndx] = logit(phiStarting, phiUnifa, phiUnifb);
if(covModel == "matern")
spParams[nuIndx] = logit(nuStarting, nuUnifa, nuUnifb);
double *wCurrent = (double *) R_alloc(n, sizeof(double));
double *w_strCurrent = (double *) R_alloc(m, sizeof(double));
F77_NAME(dcopy)(&m, w_strStarting, &incOne, w_strCurrent, &incOne);
//samples and random effects
SEXP w_r, w_str_r, samples_r, accept_r;
PROTECT(w_r = allocMatrix(REALSXP, n, nSamples)); nProtect++;
double *w = REAL(w_r); zeros(w, n*nSamples);
PROTECT(w_str_r = allocMatrix(REALSXP, m, nSamples)); nProtect++;
double *w_str = REAL(w_str_r); zeros(w_str, m*nSamples);
PROTECT(samples_r = allocMatrix(REALSXP, nParams, nSamples)); nProtect++;
double *samples = REAL(samples_r);
PROTECT(accept_r = allocMatrix(REALSXP, 1, 1)); nProtect++;
/*****************************************
Set-up MCMC alg. vars. matrices etc.
*****************************************/
int s=0, status=0, rtnStatus=0, accept=0, batchAccept = 0;
double logPostCurrent = 0, logPostCand = 0, detCand = 0;
double *P = (double *) R_alloc(nm, sizeof(double));
double *K = (double *) R_alloc(mm, sizeof(double));
double *tmp_n = (double *) R_alloc(n, sizeof(double));
double *tmp_m = (double *) R_alloc(m, sizeof(double));
double *tmp_nm = (double *) R_alloc(nm, sizeof(double));
double *theta = (double *) R_alloc(3, sizeof(double)); //phi, nu, and perhaps more in the future
double *candSpParams = (double *) R_alloc(nParams, sizeof(double));
double *w_strCand = (double *) R_alloc(m, sizeof(double));
double *wCand = (double *) R_alloc(n, sizeof(double));
double sigmaSq, phi, nu;
double *beta = (double *) R_alloc(p, sizeof(double));
double logMHRatio;
if(verbose){
Rprintf("-------------------------------------------------\n");
Rprintf("\t\tSampling\n");
Rprintf("-------------------------------------------------\n");
#ifdef Win32
R_FlushConsole();
#endif
}
logPostCurrent = R_NegInf;
GetRNGstate();
for(s = 0; s < nSamples; s++){
//propose
mvrnorm(&candSpParams[betaIndx], &spParams[betaIndx], betaTuning, p, false);
F77_NAME(dcopy)(&p, &candSpParams[betaIndx], &incOne, beta, &incOne);
candSpParams[sigmaSqIndx] = rnorm(spParams[sigmaSqIndx], sigmaSqTuning);
sigmaSq = theta[0] = exp(candSpParams[sigmaSqIndx]);
candSpParams[phiIndx] = rnorm(spParams[phiIndx], phiTuning);
phi = theta[1] = logitInv(candSpParams[phiIndx], phiUnifa, phiUnifb);
if(covModel == "matern"){
candSpParams[nuIndx] = rnorm(spParams[nuIndx], nuTuning);
nu = theta[2] = logitInv(candSpParams[nuIndx], nuUnifa, nuUnifb);
}
for(i = 0; i < m; i++){
w_strCand[i] = rnorm(w_strCurrent[i], sqrt(w_strTuning[i]));
}
//construct covariance matrices
spCovLT(knotsD, m, theta, covModel, K);
spCov(knotsCoordsD, nm, theta, covModel, P);
//invert C and log det cov
detCand = 0;
F77_NAME(dpotrf)(lower, &m, K, &m, &info); if(info != 0){error("c++ error: Cholesky failed in spGLM\n");}
for(i = 0; i < m; i++) detCand += 2*log(K[i*m+i]);
F77_NAME(dpotri)(lower, &m, K, &m, &info); if(info != 0){error("c++ error: Cholesky inverse failed in spGLM\n");}
//make \tild{w}
F77_NAME(dsymv)(lower, &m, &one, K, &m, w_strCand, &incOne, &zero, tmp_m, &incOne);
F77_NAME(dgemv)(ytran, &m, &n, &one, P, &m, tmp_m, &incOne, &zero, wCand, &incOne);
//Likelihood with Jacobian
logPostCand = 0.0;
if(betaPrior == "normal"){
for(i = 0; i < p; i++){
logPostCand += dnorm(beta[i], betaMu[i], betaSd[i], 1);
}
}
logPostCand += -1.0*(1.0+sigmaSqIGa)*log(sigmaSq)-sigmaSqIGb/sigmaSq+log(sigmaSq);
logPostCand += log(phi - phiUnifa) + log(phiUnifb - phi);
if(covModel == "matern"){
logPostCand += log(nu - nuUnifa) + log(nuUnifb - nu);
}
F77_NAME(dgemv)(ntran, &n, &p, &one, X, &n, beta, &incOne, &zero, tmp_n, &incOne);
if(family == "binomial"){
logPostCand += binomial_logpost(n, Y, tmp_n, wCand, weights);
}else if(family == "poisson"){
logPostCand += poisson_logpost(n, Y, tmp_n, wCand, weights);
}else{
error("c++ error: family misspecification in spGLM\n");
}
//(-1/2) * tmp_n` * C^-1 * tmp_n
logPostCand += -0.5*detCand-0.5*F77_NAME(ddot)(&m, w_strCand, &incOne, tmp_m, &incOne);
//
//MH accept/reject
//
//MH ratio with adjustment
logMHRatio = logPostCand - logPostCurrent;
if(runif(0.0,1.0) <= exp(logMHRatio)){
F77_NAME(dcopy)(&nParams, candSpParams, &incOne, spParams, &incOne);
F77_NAME(dcopy)(&n, wCand, &incOne, wCurrent, &incOne);
F77_NAME(dcopy)(&m, w_strCand, &incOne, w_strCurrent, &incOne);
logPostCurrent = logPostCand;
accept++;
batchAccept++;
}
/******************************
Save samples and report
*******************************/
F77_NAME(dcopy)(&nParams, spParams, &incOne, &samples[s*nParams], &incOne);
F77_NAME(dcopy)(&n, wCurrent, &incOne, &w[s*n], &incOne);
F77_NAME(dcopy)(&m, w_strCurrent, &incOne, &w_str[s*m], &incOne);
//report
if(verbose){
if(status == nReport){
Rprintf("Sampled: %i of %i, %3.2f%%\n", s, nSamples, 100.0*s/nSamples);
Rprintf("Report interval Metrop. Acceptance rate: %3.2f%%\n", 100.0*batchAccept/nReport);
Rprintf("Overall Metrop. Acceptance rate: %3.2f%%\n", 100.0*accept/s);
Rprintf("-------------------------------------------------\n");
#ifdef Win32
R_FlushConsole();
#endif
status = 0;
batchAccept = 0;
}
}
status++;
R_CheckUserInterrupt();
}//end sample loop
PutRNGstate();
//final status report
if(verbose){
Rprintf("Sampled: %i of %i, %3.2f%%\n", s, nSamples, 100.0*s/nSamples);
Rprintf("-------------------------------------------------\n");
#ifdef Win32
R_FlushConsole();
#endif
}
//untransform variance variables
for(s = 0; s < nSamples; s++){
samples[s*nParams+sigmaSqIndx] = exp(samples[s*nParams+sigmaSqIndx]);
samples[s*nParams+phiIndx] = logitInv(samples[s*nParams+phiIndx], phiUnifa, phiUnifb);
if(covModel == "matern")
samples[s*nParams+nuIndx] = logitInv(samples[s*nParams+nuIndx], nuUnifa, nuUnifb);
}
//calculate acceptance rate
REAL(accept_r)[0] = 100.0*accept/s;
//make return object
SEXP result, resultNames;
int nResultListObjs = 4;
PROTECT(result = allocVector(VECSXP, nResultListObjs)); nProtect++;
PROTECT(resultNames = allocVector(VECSXP, nResultListObjs)); nProtect++;
//samples
SET_VECTOR_ELT(result, 0, samples_r);
SET_VECTOR_ELT(resultNames, 0, mkChar("p.beta.theta.samples"));
SET_VECTOR_ELT(result, 1, accept_r);
SET_VECTOR_ELT(resultNames, 1, mkChar("acceptance"));
SET_VECTOR_ELT(result, 2, w_r);
SET_VECTOR_ELT(resultNames, 2, mkChar("p.w.samples"));
SET_VECTOR_ELT(result, 3, w_str_r);
SET_VECTOR_ELT(resultNames, 3, mkChar("p.w.knots.samples"));
namesgets(result, resultNames);
//unprotect
UNPROTECT(nProtect);
return(result);
}
SEXP spSVCPredictJoint(SEXP m_r, SEXP n_r, SEXP KDiag_r, SEXP obsD_r, SEXP predObsD_r, SEXP predD_r, SEXP q_r,
SEXP samples_r, SEXP wSamples_r, SEXP nSamples_r,
SEXP AIndx_r, SEXP phiIndx_r, SEXP nuIndx_r,
SEXP covModel_r,
SEXP verbose_r, SEXP nReport_r, SEXP nThreads_r){
/*****************************************
Common variables
*****************************************/
int i, j, k, l, b, s, h, info, nProtect=0;
char const *lower = "L";
char const *upper = "U";
char const *nUnit = "N";
char const *yUnit = "U";
char const *ntran = "N";
char const *ytran = "T";
char const *rside = "R";
char const *lside = "L";
const double one = 1.0;
const double negOne = -1.0;
const double zero = 0.0;
const int incOne = 1;
/*****************************************
Set-up
*****************************************/
double *obsD = REAL(obsD_r);
double *predObsD = REAL(predObsD_r);
double *predD = REAL(predD_r);
int m = INTEGER(m_r)[0];
int mm = m*m;
int n = INTEGER(n_r)[0];
int nn = n*n;
int nm = n*m;
int nmnm = nm*nm;
int q = INTEGER(q_r)[0];//number of prediction locations
int qm = q*m;
int qmnm = qm*nm;
int qmqm = qm*qm;
bool KDiag = static_cast<bool>(INTEGER(KDiag_r)[0]);
int nLTr = m*(m-1)/2+m;
double *samples = REAL(samples_r);
double *wSamples = REAL(wSamples_r);
int nSamples = INTEGER(nSamples_r)[0];
int AIndx = INTEGER(AIndx_r)[0];
int phiIndx = INTEGER(phiIndx_r)[0];
int nuIndx = INTEGER(nuIndx_r)[0];
std::string covModel = CHAR(STRING_ELT(covModel_r,0));
int verbose = INTEGER(verbose_r)[0];
int nReport = INTEGER(nReport_r)[0];
int nThreads = INTEGER(nThreads_r)[0];
/*****************************************
Set-up MCMC alg. vars. matrices etc.
*****************************************/
SEXP wPredSamples_r;
PROTECT(wPredSamples_r = allocMatrix(REALSXP, qm, nSamples)); nProtect++;
int status=1;
double *A = (double *) R_alloc(mm, sizeof(double)); zeros(A, mm); //to simplify a future move to the more general cross-cov model
double *K = (double *) R_alloc(nmnm, sizeof(double));
double *B = (double *) R_alloc(qmnm, sizeof(double));
double *C = (double *) R_alloc(qmqm, sizeof(double));
double *tmp_nltr = (double *) R_alloc(nLTr, sizeof(double));
double *tmp_qmnm = (double *) R_alloc(qmnm, sizeof(double));
double *tmp_qm = (double *) R_alloc(qm, sizeof(double));
double *tmp_qmqm = (double *) R_alloc(qmqm, sizeof(double));
double *phi = (double *) R_alloc(m, sizeof(double));
double *nu = (double *) R_alloc(m, sizeof(double)); zeros(nu, m); //this just remains empty of not matern
double maxNu = 0; //needed for thread safe bessel
if(covModel == "matern"){
for(s = 0; s < nSamples; s++){
for(i = 0; i < m; i++){
if(samples[(nuIndx+i)*nSamples+s] > maxNu){
maxNu = samples[(nuIndx+i)*nSamples+s];
}
}
}
}
int threadID = 0;
int bessel_ws_inc = static_cast<int>(1.0+maxNu);
double *bessel_ws = (double *) R_alloc(nThreads*bessel_ws_inc, sizeof(double));
#ifdef _OPENMP
omp_set_num_threads(nThreads);
if(verbose){
Rprintf("Source compiled with OpenMP, posterior sampling is using %i thread(s).\n", nThreads);
}
#else
if(nThreads > 1){
warning("n.omp.threads = %i, but source not compiled with OpenMP support.", nThreads);
nThreads = 1;
}
#endif
if(verbose){
Rprintf("-------------------------------------------------\n");
Rprintf("\tJoint sampling of predicted w\n");
Rprintf("-------------------------------------------------\n");
#ifdef Win32
R_FlushConsole();
#endif
}
GetRNGstate();
for(s = 0; s < nSamples; s++){
if(KDiag == false){
dcopy_(&nLTr, &samples[AIndx*nSamples+s], &nSamples, tmp_nltr, &incOne);
covExpand(tmp_nltr, A, m);//note this is K, so we need chol
F77_NAME(dpotrf)(lower, &m, A, &m, &info); if(info != 0){error("c++ error: dpotrf failed 1\n");}
clearUT(A, m); //make sure upper tri is clear
}
for(k = 0; k < m; k++){
if(KDiag){
A[k*m+k] = sqrt(samples[(AIndx+k)*nSamples+s]);
}
phi[k] = samples[(phiIndx+k)*nSamples+s];
if(covModel == "matern"){
nu[k] = samples[(nuIndx+k)*nSamples+s];
}
}
//construct covariance matrix
#ifdef _OPENMP
#pragma omp parallel for private(i, k, l, h, threadID)
#endif
for(j = 0; j < n; j++){
#ifdef _OPENMP
threadID = omp_get_thread_num();
#endif
for(i = 0; i < n; i++){
for(k = 0; k < m; k++){
for(l = 0; l < m; l++){
K[(k+j*m)*nm+(i*m+l)] = 0.0;
for(h = 0; h < m; h++){
K[(k+j*m)*nm+(i*m+l)] += A[k+m*h]*A[l+m*h]*spCorTS(obsD[j*n+i], phi[h], nu[h], covModel, &bessel_ws[threadID*bessel_ws_inc]);
}
}
}
}
}
#ifdef _OPENMP
#pragma omp parallel for private(i, k, l, h, threadID)
#endif
for(j = 0; j < n; j++){
#ifdef _OPENMP
threadID = omp_get_thread_num();
#endif
for(i = 0; i < q; i++){
for(k = 0; k < m; k++){
for(l = 0; l < m; l++){
B[(k+j*m)*qm+(i*m+l)] = 0.0;
for(h = 0; h < m; h++){
B[(k+j*m)*qm+(i*m+l)] += A[k+m*h]*A[l+m*h]*spCorTS(predObsD[j*q+i], phi[h], nu[h], covModel, &bessel_ws[threadID*bessel_ws_inc]);
}
}
}
}
}
//printMtrx(B, qm, nm);
#ifdef _OPENMP
#pragma omp parallel for private(i, k, l, h, threadID)
#endif
for(j = 0; j < q; j++){
#ifdef _OPENMP
threadID = omp_get_thread_num();
#endif
for(i = 0; i < q; i++){
for(k = 0; k < m; k++){
for(l = 0; l < m; l++){
C[(k+j*m)*qm+(i*m+l)] = 0.0;
for(h = 0; h < m; h++){
C[(k+j*m)*qm+(i*m+l)] += A[k+m*h]*A[l+m*h]*spCorTS(predD[j*q+i], phi[h], nu[h], covModel, &bessel_ws[threadID*bessel_ws_inc]);
}
}
}
}
}
F77_NAME(dpotrf)(lower, &nm, K, &nm, &info); if(info != 0){error("c++ error: dpotrf failed 1\n");}
F77_NAME(dpotri)(lower, &nm, K, &nm, &info); if(info != 0){error("c++ error: dpotri failed\n");}
F77_NAME(dsymm)(rside, lower, &qm, &nm, &one, K, &nm, B, &qm, &zero, tmp_qmnm, &qm);
//mu
F77_NAME(dgemv)(ntran, &qm, &nm, &one, tmp_qmnm, &qm, &wSamples[s*nm], &incOne, &zero, tmp_qm, &incOne);
//var
F77_NAME(dgemm)(ntran, ytran, &qm, &qm, &nm, &one, tmp_qmnm, &qm, B, &qm, &zero, tmp_qmqm, &qm);
for(i = 0; i < qmqm; i++){
C[i] = C[i] - tmp_qmqm[i];
}
F77_NAME(dpotrf)(lower, &qm, C, &qm, &info); if(info != 0){error("c++ error: dpotrf failed 2\n");}
mvrnorm(&REAL(wPredSamples_r)[s*qm], tmp_qm, C, qm, false);
//report
if(verbose){
if(status == nReport){
Rprintf("Sampled: %i of %i, %3.2f%%\n", s, nSamples, 100.0*s/nSamples);
#ifdef Win32
R_FlushConsole();
#endif
status = 0;
}
}
status++;
R_CheckUserInterrupt();
}//end sample loop
PutRNGstate();
//make return object
SEXP result_r, resultName_r;
int nResultListObjs = 1;
PROTECT(result_r = allocVector(VECSXP, nResultListObjs)); nProtect++;
PROTECT(resultName_r = allocVector(VECSXP, nResultListObjs)); nProtect++;
//samples
SET_VECTOR_ELT(result_r, 0, wPredSamples_r);
SET_VECTOR_ELT(resultName_r, 0, mkChar("p.w.predictive.samples"));
namesgets(result_r, resultName_r);
//unprotect
UNPROTECT(nProtect);
return(result_r);
}
