//[[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); }