static SEXP getSPSSvaluelabels(struct dictionary *dict)
{
SEXP ans, somelabels, somevalues;
int nlabels, nvars, i, j;
struct value_label **flattened_labels;
struct avl_tree *labelset;
unsigned char tmp[MAX_SHORT_STRING+1];
nvars = dict->nvar;
if (nvars == 0) return R_NilValue;
PROTECT(ans = allocVector(VECSXP, nvars));
for(i = 0; i < nvars; i++) {
labelset = (dict->var)[i]->val_lab;
if (!labelset) continue;
nlabels = R_avl_count(labelset);
flattened_labels = avlFlatten(labelset);
PROTECT(somelabels = allocVector(STRSXP, nlabels));
if ((dict->var)[i]->type == NUMERIC) {
double *rx;
PROTECT(somevalues = allocVector(REALSXP, nlabels));
rx = REAL(somevalues);
for(j = 0; j < nlabels; j++) {
SET_STRING_ELT(somelabels, j, mkChar(flattened_labels[j]->s));
rx[j] = flattened_labels[j]->v.f;
}
} else {
PROTECT(somevalues = allocVector(STRSXP, nlabels));
for(j = 0; j < nlabels; j++) {
SET_STRING_ELT(somelabels, j, mkChar(flattened_labels[j]->s));
memcpy(tmp,flattened_labels[j]->v.s, MAX_SHORT_STRING);
tmp[MAX_SHORT_STRING] = '\0';
SET_STRING_ELT(somevalues, j, mkChar((char *)tmp));
}
}
Free(flattened_labels);
namesgets(somevalues, somelabels);
SET_VECTOR_ELT(ans, i, somevalues);
UNPROTECT(2); /*somevalues, somelabels*/
}
UNPROTECT(1);
return ans;
}
/* 'name' should be 1-element STRSXP or SYMSXP */
SEXP setAttrib(SEXP vec, SEXP name, SEXP val)
{
PROTECT(vec);
PROTECT(name);
if (isString(name))
name = install(translateChar(STRING_ELT(name, 0)));
if (val == R_NilValue) {
UNPROTECT(2);
return removeAttrib(vec, name);
}
/* We allow attempting to remove names from NULL */
if (vec == R_NilValue)
error(_("attempt to set an attribute on NULL"));
if (NAMED(val)) val = duplicate(val);
SET_NAMED(val, NAMED(val) | NAMED(vec));
UNPROTECT(2);
if (name == R_NamesSymbol)
return namesgets(vec, val);
else if (name == R_DimSymbol)
return dimgets(vec, val);
else if (name == R_DimNamesSymbol)
return dimnamesgets(vec, val);
else if (name == R_ClassSymbol)
return classgets(vec, val);
else if (name == R_TspSymbol)
return tspgets(vec, val);
else if (name == R_CommentSymbol)
return commentgets(vec, val);
else if (name == R_RowNamesSymbol)
return row_names_gets(vec, val);
else
return installAttrib(vec, name, val);
}
SEXP spMisalign(SEXP Y_r, SEXP X_r, SEXP p_r, SEXP n_r, SEXP m_r, SEXP coordsD_r,
SEXP betaPrior_r, SEXP betaNorm_r,
SEXP KPrior_r, SEXP KPriorName_r,
SEXP PsiPrior_r,
SEXP nuUnif_r, SEXP phiUnif_r,
SEXP phiStarting_r, SEXP AStarting_r, SEXP PsiStarting_r, SEXP nuStarting_r,
SEXP phiTuning_r, SEXP ATuning_r, SEXP PsiTuning_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 h, i, j, k, l, b, s, ii, jj, kk, 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);
int *n = INTEGER(n_r);
int m = INTEGER(m_r)[0];
int nLTr = m*(m-1)/2+m;
int N = 0;
int P = 0;
for(i = 0; i < m; i++){
N += n[i];
P += p[i];
}
int mm = m*m;
int NN = N*N;
int NP = N*P;
int PP = P*P;
double *coordsD = REAL(coordsD_r);
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 *phiUnif = REAL(phiUnif_r);
std::string KPriorName = CHAR(STRING_ELT(KPriorName_r,0));
double KIW_df = 0; double *KIW_S = NULL;
double *ANormMu = NULL; double *ANormC = NULL;
if(KPriorName == "IW"){
KIW_S = (double *) R_alloc(mm, sizeof(double));
KIW_df = REAL(VECTOR_ELT(KPrior_r, 0))[0]; KIW_S = REAL(VECTOR_ELT(KPrior_r, 1));
}else{//assume A normal (can add more specifications later)
ANormMu = (double *) R_alloc(nLTr, sizeof(double));
ANormC = (double *) R_alloc(nLTr, sizeof(double));
for(i = 0; i < nLTr; i++){
ANormMu[i] = REAL(VECTOR_ELT(KPrior_r, 0))[i];
ANormC[i] = REAL(VECTOR_ELT(KPrior_r, 1))[i];
}
}
bool nugget = static_cast<bool>(INTEGER(nugget_r)[0]);
double *PsiIGa = NULL; double *PsiIGb = NULL;
if(nugget){
PsiIGa = (double *) R_alloc(m, sizeof(double));
PsiIGb = (double *) R_alloc(m, sizeof(double));
for(i = 0; i < m; i++){
PsiIGa[i] = REAL(VECTOR_ELT(PsiPrior_r, 0))[i];
PsiIGb[i] = REAL(VECTOR_ELT(PsiPrior_r, 1))[i];
}
}
//matern
double *nuUnif = NULL;
if(covModel == "matern"){
nuUnif = REAL(nuUnif_r);
}
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 outcome variables.\n\n", m);
Rprintf("Number of observations within each outcome:"); printVec(n, m);
Rprintf("\nNumber of covariates for each outcome (including intercept if specified):"); printVec(p, m);
Rprintf("\nTotal number of observations: %i\n\n", N);
Rprintf("Total number of covariates (including intercept if specified): %i\n\n", P);
Rprintf("Using the %s spatial correlation model.\n\n", covModel.c_str());
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("Psi 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");
if(KPriorName == "IW"){
Rprintf("\tK IW hyperpriors df=%.5f, S=\n", KIW_df);
printMtrx(KIW_S, m, m);
}else{
Rprintf("\tA Normal hyperpriors\n");
Rprintf("\t\tparameter\tmean\tvar\n");
for(j = 0, i = 0; j < m; j++){
for(k = j; k < m; k++, i++){
Rprintf("\t\tA[%i,%i]\t\t%3.1f\t%1.2f\n", j+1, k+1, ANormMu[i], ANormC[i]);
}
}
}
Rprintf("\n");
if(nugget){
Rprintf("\tDiag(Psi) IG hyperpriors\n");
Rprintf("\t\tparameter\tshape\tscale\n");
for(j = 0; j < m; j++){
Rprintf("\t\tPsi[%i,%i]\t%3.1f\t%1.2f\n", j+1, j+1, PsiIGa[j], PsiIGb[j]);
}
}
Rprintf("\n");
Rprintf("\tphi Unif hyperpriors\n");
Rprintf("\t\tparameter\ta\tb\n");
for(j = 0; j < m; j++){
Rprintf("\t\tphi[%i]\t\t%0.5f\t%0.5f\n", j+1, phiUnif[j*2], phiUnif[j*2+1]);
}
Rprintf("\n");
if(covModel == "matern"){
Rprintf("\tnu Unif hyperpriors\n");
for(j = 0; j < m; j++){
Rprintf("\t\tnu[%i]\t\t%0.5f\t%0.5f\n", j+1, nuUnif[j*2], nuUnif[j*2+1]);
}
Rprintf("\n");
}
}
/*****************************************
Set-up MCMC sample matrices etc.
*****************************************/
//spatial parameters
int nParams, AIndx, PsiIndx, phiIndx, nuIndx;
if(!nugget && covModel != "matern"){
nParams = nLTr+m;//A, phi
AIndx = 0; phiIndx = nLTr;
}else if(nugget && covModel != "matern"){
nParams = nLTr+m+m;//A, diag(Psi), phi
AIndx = 0; PsiIndx = nLTr; phiIndx = PsiIndx+m;
}else if(!nugget && covModel == "matern"){
nParams = nLTr+2*m;//A, phi, nu
AIndx = 0; phiIndx = nLTr, nuIndx = phiIndx+m;
}else{
nParams = nLTr+3*m;//A, diag(Psi), phi, nu
AIndx = 0; PsiIndx = nLTr, phiIndx = PsiIndx+m, nuIndx = phiIndx+m;
}
double *params = (double *) R_alloc(nParams, sizeof(double));
//starting
covTrans(REAL(AStarting_r), ¶ms[AIndx], m);
if(nugget){
for(i = 0; i < m; i++){
params[PsiIndx+i] = log(REAL(PsiStarting_r)[i]);
}
}
for(i = 0; i < m; i++){
params[phiIndx+i] = logit(REAL(phiStarting_r)[i], phiUnif[i*2], phiUnif[i*2+1]);
if(covModel == "matern"){
params[nuIndx+i] = logit(REAL(nuStarting_r)[i], nuUnif[i*2], nuUnif[i*2+1]);
}
}
//tuning and fixed
double *tuning = (double *) R_alloc(nParams, sizeof(double));
int *fixed = (int *) R_alloc(nParams, sizeof(int)); zeros(fixed, nParams);
for(i = 0; i < nLTr; i++){
tuning[AIndx+i] = REAL(ATuning_r)[i];
if(tuning[AIndx+i] == 0){
fixed[AIndx+i] = 1;
}
}
if(nugget){
for(i = 0; i < m; i++){
tuning[PsiIndx+i] = REAL(PsiTuning_r)[i];
if(tuning[PsiIndx+i] == 0){
fixed[PsiIndx+i] = 1;
}
}
}
for(i = 0; i < m; i++){
tuning[phiIndx+i] = REAL(phiTuning_r)[i];
if(tuning[phiIndx+i] == 0){
fixed[phiIndx+i] = 1;
}
if(covModel == "matern"){
tuning[nuIndx+i] = REAL(nuTuning_r)[i];
if(tuning[nuIndx+i] == 0){
fixed[nuIndx+i] = 1;
}
}
}
for(i = 0; i < nParams; i++){
tuning[i] = log(sqrt(tuning[i]));
}
//return stuff
SEXP samples_r, accept_r, tuning_r;
PROTECT(samples_r = allocMatrix(REALSXP, nParams, nSamples)); nProtect++;
if(amcmc){
PROTECT(accept_r = allocMatrix(REALSXP, nParams, nBatch)); nProtect++;
PROTECT(tuning_r = allocMatrix(REALSXP, nParams, nBatch)); nProtect++;
}else{
PROTECT(accept_r = allocMatrix(REALSXP, 1, nSamples/nReport)); nProtect++;
}
// /*****************************************
// Set-up MCMC alg. vars. matrices etc.
// *****************************************/
int status=1, batchAccept=0, reportCnt=0;
double logMHRatio =0, logPostCurrent = R_NegInf, logPostCand = 0, det = 0, paramsjCurrent = 0;
double Q, logDetK, SKtrace;
double *paramsCurrent = (double *) R_alloc(nParams, sizeof(double));
double *accept = (double *) R_alloc(nParams, sizeof(double)); zeros(accept, nParams);
double *C = (double *) R_alloc(NN, sizeof(double));
double *K = (double *) R_alloc(mm, sizeof(double));
double *Psi = (double *) R_alloc(m, sizeof(double));
double *A = (double *) R_alloc(mm, sizeof(double));
double *phi = (double *) R_alloc(m, sizeof(double));
double *nu = (double *) R_alloc(m, sizeof(double));
int P1 = P+1;
double *vU = (double *) R_alloc(N*P1, sizeof(double));
double *z = (double *) R_alloc(N, sizeof(double));
double *tmp_N = (double *) R_alloc(N, sizeof(double));
double *tmp_mm = (double *) R_alloc(mm, sizeof(double));
double *tmp_PP = (double *) R_alloc(PP, sizeof(double));
double *tmp_P = (double *) R_alloc(P, sizeof(double));
double *tmp_NN = NULL;
double *Cbeta = NULL;
if(betaPrior == "normal"){
tmp_NN = (double *) R_alloc(NN, sizeof(double));
Cbeta = (double *) R_alloc(NN, sizeof(double));
F77_NAME(dgemv)(ntran, &N, &P, &negOne, X, &N, betaMu, &incOne, &zero, z, &incOne);
F77_NAME(daxpy)(&N, &one, Y, &incOne, z, &incOne);
F77_NAME(dsymm)(rside, lower, &N, &P, &one, betaC, &P, X, &N, &zero, vU, &N);
F77_NAME(dgemm)(ntran, ytran, &N, &N, &P, &one, vU, &N, X, &N, &zero, tmp_NN, &N);
}
int sl, sk;
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
covTransInvExpand(¶ms[AIndx], A, m);
for(k = 0; k < m; k++){
phi[k] = logitInv(params[phiIndx+k], phiUnif[k*2], phiUnif[k*2+1]);
if(covModel == "matern"){
nu[k] = logitInv(params[nuIndx+k], nuUnif[k*2], nuUnif[k*2+1]);
}
}
if(nugget){
for(k = 0; k < m; k++){
Psi[k] = exp(params[PsiIndx+k]);
}
}
//construct covariance matrix
sl = sk = 0;
for(k = 0; k < m; k++){
sl = 0;
for(l = 0; l < m; l++){
for(kk = 0; kk < n[k]; kk++){
for(jj = 0; jj < n[l]; jj++){
C[(sl+jj)*N+(sk+kk)] = 0.0;
for(ii = 0; ii < m; ii++){
C[(sl+jj)*N+(sk+kk)] += A[k+m*ii]*A[l+m*ii]*spCor(coordsD[(sl+jj)*N+(sk+kk)], phi[ii], nu[ii], covModel);
}
}
}
sl += n[l];
}
sk += n[k];
}
if(nugget){
sl = 0;
for(l = 0; l < m; l++){
for(k = 0; k < n[l]; k++){
C[(sl+k)*N+(sl+k)] += Psi[l];
}
sl += n[l];
}
}
if(betaPrior == "normal"){
for(k = 0; k < N; k++){
for(l = k; l < N; l++){
Cbeta[k*N+l] = C[k*N+l]+tmp_NN[k*N+l];
}
}
det = 0;
F77_NAME(dpotrf)(lower, &N, Cbeta, &N, &info); if(info != 0){error("c++ error: dpotrf failed\n");}
for(k = 0; k < N; k++) det += 2*log(Cbeta[k*N+k]);
F77_NAME(dcopy)(&N, z, &incOne, tmp_N, &incOne);
F77_NAME(dtrsv)(lower, ntran, nUnit, &N, Cbeta, &N, tmp_N, &incOne);//u = L^{-1}(y-X'beta)
Q = pow(F77_NAME(dnrm2)(&N, tmp_N, &incOne),2);
}else{//beta flat
det = 0;
F77_NAME(dpotrf)(lower, &N, C, &N, &info); if(info != 0){error("c++ error: dpotrf failed\n");}
for(k = 0; k < N; k++) det += 2*log(C[k*N+k]);
F77_NAME(dcopy)(&N, Y, &incOne, vU, &incOne);
F77_NAME(dcopy)(&NP, X, &incOne, &vU[N], &incOne);
F77_NAME(dtrsm)(lside, lower, ntran, nUnit, &N, &P1, &one, C, &N, vU, &N);//L^{-1}[v:U] = [y:X]
F77_NAME(dgemm)(ytran, ntran, &P, &P, &N, &one, &vU[N], &N, &vU[N], &N, &zero, tmp_PP, &P); //U'U
F77_NAME(dpotrf)(lower, &P, tmp_PP, &P, &info); if(info != 0){error("c++ error: dpotrf failed\n");}
for(k = 0; k < P; k++) det += 2*log(tmp_PP[k*P+k]);
F77_NAME(dgemv)(ytran, &N, &P, &one, &vU[N], &N, vU, &incOne, &zero, tmp_P, &incOne); //U'v
F77_NAME(dtrsv)(lower, ntran, nUnit, &P, tmp_PP, &P, tmp_P, &incOne);
Q = pow(F77_NAME(dnrm2)(&N, vU, &incOne),2) - pow(F77_NAME(dnrm2)(&P, tmp_P, &incOne),2) ;
}
//
//priors, jacobian adjustments, and likelihood
//
logPostCand = 0.0;
if(KPriorName == "IW"){
logDetK = 0.0;
SKtrace = 0.0;
for(k = 0; k < m; k++){logDetK += 2*log(A[k*m+k]);}
//jacobian \sum_{i=1}^{m} (m-i+1)*log(a_ii)+log(a_ii)
for(k = 0; k < m; k++){logPostCand += (m-k)*log(A[k*m+k])+log(A[k*m+k]);}
//S*K^-1
F77_NAME(dpotri)(lower, &m, A, &m, &info); if(info != 0){error("c++ error: dpotri failed\n");}
F77_NAME(dsymm)(rside, lower, &m, &m, &one, A, &m, KIW_S, &m, &zero, tmp_mm, &m);
for(k = 0; k < m; k++){SKtrace += tmp_mm[k*m+k];}
logPostCand += -0.5*(KIW_df+m+1)*logDetK - 0.5*SKtrace;
}else{
for(k = 0; k < nLTr; k++){
logPostCand += dnorm(params[AIndx+k], ANormMu[k], sqrt(ANormC[k]), 1);
}
}
if(nugget){
for(k = 0; k < m; k++){
logPostCand += -1.0*(1.0+PsiIGa[k])*log(Psi[k])-PsiIGb[k]/Psi[k]+log(Psi[k]);
}
}
for(k = 0; k < m; k++){
logPostCand += log(phi[k] - phiUnif[k*2]) + log(phiUnif[k*2+1] - phi[k]);
if(covModel == "matern"){
logPostCand += log(nu[k] - nuUnif[k*2]) + log(nuUnif[k*2+1] - nu[k]);
}
}
logPostCand += -0.5*det-0.5*Q;
//
//MH accept/reject
//
logMHRatio = logPostCand - logPostCurrent;
if(runif(0.0,1.0) <= exp(logMHRatio)){
logPostCurrent = logPostCand;
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
/******************************
Save samples
*******************************/
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(status == nReport){
if(verbose){
if(amcmc){
Rprintf("Batch: %i of %i, %3.2f%%\n", b+1, nBatch, 100.0*(b+1)/nBatch);
Rprintf("\tparameter\tacceptance\ttuning\n");
for(j = 0, i = 0; j < m; j++){
for(k = j; k < m; k++, i++){
Rprintf("\tA[%i,%i]\t\t%3.1f\t\t%1.2f\n", j+1, k+1, 100.0*REAL(accept_r)[b*nParams+AIndx+i], exp(tuning[AIndx+i]));
}
}
if(nugget){
for(j = 0; j < m; j++){
Rprintf("\tPsi[%i,%i]\t%3.1f\t\t%1.2f\n", j+1, j+1, 100.0*REAL(accept_r)[b*nParams+PsiIndx+j], exp(tuning[PsiIndx+j]));
}
}
for(j = 0; j < m; j++){
Rprintf("\tphi[%i]\t\t%3.1f\t\t%1.2f\n", j+1, 100.0*REAL(accept_r)[b*nParams+phiIndx+j], exp(tuning[phiIndx+j]));
}
if(covModel == "matern"){
Rprintf("\n");
for(j = 0; j < m; j++){
Rprintf("\tnu[%i]\t\t%3.1f\t\t%1.2f\n", j+1, 100.0*REAL(accept_r)[b*nParams+nuIndx+j], exp(tuning[nuIndx+j]));
}
}
}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
}
if(!amcmc){
REAL(accept_r)[reportCnt] = 100.0*batchAccept/nReport;
reportCnt++;
}
status = 0;
batchAccept = 0;
}
status++;
}//end sample loop
PutRNGstate();
//untransform variance variables
for(s = 0; s < nSamples; s++){
covTransInv(&REAL(samples_r)[s*nParams+AIndx], &REAL(samples_r)[s*nParams+AIndx], m);
if(nugget){
for(i = 0; i < m; i++){
REAL(samples_r)[s*nParams+PsiIndx+i] = exp(REAL(samples_r)[s*nParams+PsiIndx+i]);
}
}
for(i = 0; i < m; i++){
REAL(samples_r)[s*nParams+phiIndx+i] = logitInv(REAL(samples_r)[s*nParams+phiIndx+i], phiUnif[i*2], phiUnif[i*2+1]);
if(covModel == "matern"){
REAL(samples_r)[s*nParams+nuIndx+i] = logitInv(REAL(samples_r)[s*nParams+nuIndx+i], nuUnif[i*2], nuUnif[i*2+1]);
}
}
}
//make return object
SEXP result_r, resultName_r;
int nResultListObjs = 2;
if(amcmc){
nResultListObjs++;
}
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"));
if(amcmc){
SET_VECTOR_ELT(result_r, 2, tuning_r);
SET_VECTOR_ELT(resultName_r, 2, mkChar("tuning"));
}
namesgets(result_r, resultName_r);
//unprotect
UNPROTECT(nProtect);
return(result_r);
}
SEXP scdd_f(SEXP m, SEXP h, SEXP roworder, SEXP adjacency,
SEXP inputadjacency, SEXP incidence, SEXP inputincidence)
{
int i, j, k;
GetRNGstate();
if (! isMatrix(m))
error("'m' must be matrix");
if (! isLogical(h))
error("'h' must be logical");
if (! isString(roworder))
error("'roworder' must be character");
if (! isLogical(adjacency))
error("'adjacency' must be logical");
if (! isLogical(inputadjacency))
error("'inputadjacency' must be logical");
if (! isLogical(incidence))
error("'incidence' must be logical");
if (! isLogical(inputincidence))
error("'inputincidence' must be logical");
if (LENGTH(h) != 1)
error("'h' must be scalar");
if (LENGTH(roworder) != 1)
error("'roworder' must be scalar");
if (LENGTH(adjacency) != 1)
error("'adjacency' must be scalar");
if (LENGTH(inputadjacency) != 1)
error("'inputadjacency' must be scalar");
if (LENGTH(incidence) != 1)
error("'incidence' must be scalar");
if (LENGTH(inputincidence) != 1)
error("'inputincidence' must be scalar");
if (! isReal(m))
error("'m' must be double");
SEXP m_dim;
PROTECT(m_dim = getAttrib(m, R_DimSymbol));
int nrow = INTEGER(m_dim)[0];
int ncol = INTEGER(m_dim)[1];
UNPROTECT(1);
#ifdef BLATHER
printf("nrow = %d\n", nrow);
printf("ncol = %d\n", ncol);
#endif /* BLATHER */
if ((! LOGICAL(h)[0]) && nrow <= 0)
error("no rows in 'm', not allowed for V-representation");
if (ncol <= 2)
error("no cols in m[ , - c(1, 2)]");
for (i = 0; i < nrow * ncol; i++)
if (! R_finite(REAL(m)[i]))
error("'m' not finite-valued");
for (i = 0; i < nrow; i++) {
double foo = REAL(m)[i];
if (! (foo == 0.0 || foo == 1.0))
error("column one of 'm' not zero-or-one valued");
}
if (! LOGICAL(h)[0])
for (i = nrow; i < 2 * nrow; i++) {
double foo = REAL(m)[i];
if (! (foo == 0.0 || foo == 1.0))
error("column two of 'm' not zero-or-one valued");
}
ddf_set_global_constants();
myfloat value;
ddf_init(value);
ddf_MatrixPtr mf = ddf_CreateMatrix(nrow, ncol - 1);
/* note our matrix has one more column than Fukuda's */
/* representation */
if(LOGICAL(h)[0])
mf->representation = ddf_Inequality;
else
mf->representation = ddf_Generator;
mf->numbtype = ddf_Real;
/* linearity */
for (i = 0; i < nrow; i++) {
double foo = REAL(m)[i];
if (foo == 1.0)
set_addelem(mf->linset, i + 1);
/* note conversion from zero-origin to one-origin indexing */
}
/* matrix */
for (j = 1, k = nrow; j < ncol; j++)
for (i = 0; i < nrow; i++, k++) {
ddf_set_d(value, REAL(m)[k]);
ddf_set(mf->matrix[i][j - 1], value);
/* note our matrix has one more column than Fukuda's */
}
ddf_RowOrderType strategy = ddf_LexMin;
const char *row_str = CHAR(STRING_ELT(roworder, 0));
if(strcmp(row_str, "maxindex") == 0)
strategy = ddf_MaxIndex;
else if(strcmp(row_str, "minindex") == 0)
strategy = ddf_MinIndex;
else if(strcmp(row_str, "mincutoff") == 0)
strategy = ddf_MinCutoff;
else if(strcmp(row_str, "maxcutoff") == 0)
strategy = ddf_MaxCutoff;
else if(strcmp(row_str, "mixcutoff") == 0)
strategy = ddf_MixCutoff;
else if(strcmp(row_str, "lexmin") == 0)
strategy = ddf_LexMin;
else if(strcmp(row_str, "lexmax") == 0)
strategy = ddf_LexMax;
else if(strcmp(row_str, "randomrow") == 0)
strategy = ddf_RandomRow;
else
error("roworder not recognized");
ddf_ErrorType err = ddf_NoError;
ddf_PolyhedraPtr poly = ddf_DDMatrix2Poly2(mf, strategy, &err);
if (poly->child != NULL && poly->child->CompStatus == ddf_InProgress) {
ddf_FreeMatrix(mf);
ddf_FreePolyhedra(poly);
ddf_clear(value);
ddf_free_global_constants();
error("Computation failed, floating-point arithmetic problem\n");
}
if (err != ddf_NoError) {
rrf_WriteErrorMessages(err);
ddf_FreeMatrix(mf);
ddf_FreePolyhedra(poly);
ddf_clear(value);
ddf_free_global_constants();
error("failed");
}
ddf_MatrixPtr aout = NULL;
if (poly->representation == ddf_Inequality)
aout = ddf_CopyGenerators(poly);
else if (poly->representation == ddf_Generator)
aout = ddf_CopyInequalities(poly);
else
error("Cannot happen! poly->representation no good\n");
if (aout == NULL)
error("Cannot happen! aout no good\n");
int mrow = aout->rowsize;
int mcol = aout->colsize;
if (mcol + 1 != ncol)
error("Cannot happen! computed matrix has wrong number of columns");
#ifdef BLATHER
printf("mrow = %d\n", mrow);
printf("mcol = %d\n", mcol);
#endif /* BLATHER */
SEXP bar;
PROTECT(bar = allocMatrix(REALSXP, mrow, ncol));
/* linearity output */
for (i = 0; i < mrow; i++)
if (set_member(i + 1, aout->linset))
REAL(bar)[i] = 1.0;
else
REAL(bar)[i] = 0.0;
/* note conversion from zero-origin to one-origin indexing */
/* matrix output */
for (j = 1, k = mrow; j < ncol; j++)
for (i = 0; i < mrow; i++, k++) {
double ax = ddf_get_d(aout->matrix[i][j - 1]);
/* note our matrix has one more column than Fukuda's */
REAL(bar)[k] = ax;
}
int nresult = 1;
SEXP baz_adj = NULL;
if (LOGICAL(adjacency)[0]) {
ddf_SetFamilyPtr sout = ddf_CopyAdjacency(poly);
PROTECT(baz_adj = rrf_WriteSetFamily(sout));
ddf_FreeSetFamily(sout);
nresult++;
}
SEXP baz_inp_adj = NULL;
if (LOGICAL(inputadjacency)[0]) {
ddf_SetFamilyPtr sout = ddf_CopyInputAdjacency(poly);
PROTECT(baz_inp_adj = rrf_WriteSetFamily(sout));
ddf_FreeSetFamily(sout);
nresult++;
}
SEXP baz_inc = NULL;
if (LOGICAL(incidence)[0]) {
ddf_SetFamilyPtr sout = ddf_CopyIncidence(poly);
PROTECT(baz_inc = rrf_WriteSetFamily(sout));
ddf_FreeSetFamily(sout);
nresult++;
}
SEXP baz_inp_inc = NULL;
if (LOGICAL(inputincidence)[0]) {
ddf_SetFamilyPtr sout = ddf_CopyInputIncidence(poly);
PROTECT(baz_inp_inc = rrf_WriteSetFamily(sout));
ddf_FreeSetFamily(sout);
nresult++;
}
SEXP result, resultnames;
PROTECT(result = allocVector(VECSXP, nresult));
PROTECT(resultnames = allocVector(STRSXP, nresult));
SET_STRING_ELT(resultnames, 0, mkChar("output"));
SET_VECTOR_ELT(result, 0, bar);
int iresult = 1;
if (baz_adj) {
SET_STRING_ELT(resultnames, iresult, mkChar("adjacency"));
SET_VECTOR_ELT(result, iresult, baz_adj);
iresult++;
}
if (baz_inp_adj) {
SET_STRING_ELT(resultnames, iresult, mkChar("inputadjacency"));
SET_VECTOR_ELT(result, iresult, baz_inp_adj);
iresult++;
}
if (baz_inc) {
SET_STRING_ELT(resultnames, iresult, mkChar("incidence"));
SET_VECTOR_ELT(result, iresult, baz_inc);
iresult++;
}
if (baz_inp_inc) {
SET_STRING_ELT(resultnames, iresult, mkChar("inputincidence"));
SET_VECTOR_ELT(result, iresult, baz_inp_inc);
iresult++;
}
namesgets(result, resultnames);
if (aout->objective != ddf_LPnone)
error("Cannot happen! aout->objective != ddf_LPnone\n");
ddf_FreeMatrix(aout);
ddf_FreeMatrix(mf);
ddf_FreePolyhedra(poly);
ddf_clear(value);
ddf_free_global_constants();
UNPROTECT(2 + nresult);
PutRNGstate();
return result;
}
static SEXP
read_SPSS_SAVE(const char *filename)
{
struct file_handle *fh = fh_get_handle_by_filename(filename);
struct sfm_read_info inf;
struct dictionary *dict;
SEXP ans;
SEXP ans_names;
union value *case_vals;
int i;
int nvar_label;
int nval = 0;
SEXP val_labels;
SEXP variable_labels;
SEXP miss_labels; int have_miss = 0;
/* package multcomp has an example in which this does not get
initialized */
inf.encoding = 0;
dict = sfm_read_dictionary(fh, &inf);
ans = PROTECT(allocVector(VECSXP, dict->nvar));
ans_names = PROTECT(allocVector(STRSXP, dict->nvar));
/* Set the fv and lv elements of all variables in the
dictionary. */
for (i = 0; i < dict->nvar; i++) {
struct variable *v = dict->var[i];
v->fv = nval;
nval += v->nv;
}
dict->nval = nval;
if (!nval)
error(_("nval is 0"));
case_vals = (union value *) R_alloc(dict->nval, sizeof(union value));
for (i = 0; i < dict->nvar; i++) {
struct variable *v = dict->var[i];
if (v->get.fv == -1)
continue;
SET_STRING_ELT(ans_names, i, mkChar(dict->var[i]->name));
if (v->type == NUMERIC) {
SET_VECTOR_ELT(ans, i, allocVector(REALSXP, inf.ncases));
} else {
SET_VECTOR_ELT(ans, i, allocVector(STRSXP, inf.ncases));
case_vals[v->fv].c =
(unsigned char *) R_alloc(v->width + 1, 1);
((char *) &case_vals[v->fv].c[0])[v->width] = '\0';
}
}
for (i = 0; i < inf.ncases; i++) {
int j;
sfm_read_case(fh, case_vals, dict);
for (j = 0; j < dict->nvar; j++) {
struct variable *v = dict->var[j];
if (v->get.fv == -1)
continue;
if (v->type == NUMERIC) {
REAL(VECTOR_ELT(ans, j))[i] = case_vals[v->fv].f;
} else {
SET_STRING_ELT(VECTOR_ELT(ans, j), i,
mkChar((char *)case_vals[v->fv].c));
}
}
}
sfm_maybe_close(fh);
/* get all the value labels */
PROTECT(val_labels = getSPSSvaluelabels(dict));
namesgets(val_labels, duplicate(ans_names));
setAttrib(ans, install("label.table"), val_labels);
UNPROTECT(1);
/* get SPSS variable labels */
PROTECT(variable_labels = allocVector(STRSXP, dict->nvar));
nvar_label = 0;
for (i = 0; i < dict->nvar; i++) {
char *lab = dict->var[i]->label;
if (lab != NULL) {
nvar_label++;
SET_STRING_ELT(variable_labels, i, mkChar(lab));
}
}
if (nvar_label > 0) {
namesgets(variable_labels, ans_names);
setAttrib(ans,install("variable.labels"), variable_labels);
}
UNPROTECT(1);
/* report missingness */
PROTECT(miss_labels = getSPSSmissing(dict, &have_miss));
if(have_miss) {
namesgets(miss_labels, duplicate(ans_names));
setAttrib(ans, install("missings"), miss_labels);
}
UNPROTECT(1);
free_dictionary(dict);
setAttrib(ans, R_NamesSymbol, ans_names);
setAttrib(ans, install("codepage"), ScalarInteger(inf.encoding));
UNPROTECT(2);
return ans;
}
static SEXP
read_SPSS_PORT(const char *filename)
{
struct file_handle *fh = fh_get_handle_by_filename(filename);
struct pfm_read_info inf;
struct dictionary *dict = pfm_read_dictionary(fh, &inf);
SEXP ans = PROTECT(allocVector(VECSXP, dict->nvar));
SEXP ans_names = PROTECT(allocVector(STRSXP, dict->nvar));
union value *case_vals;
int i;
int ncases = 0;
int N = 10;
int nval = 0;
int nvar_label;
SEXP val_labels;
SEXP variable_labels;
SEXP miss_labels; int have_miss = 0;
/* Set the fv and lv elements of all variables in the
dictionary. */
for (i = 0; i < dict->nvar; i++) {
struct variable *v = dict->var[i];
v->fv = nval;
nval += v->nv;
}
dict->nval = nval;
if (!nval)
error(_("nval is 0"));
case_vals = (union value *) R_alloc(dict->nval, sizeof(union value));
for (i = 0; i < dict->nvar; i++) {
struct variable *v = dict->var[i];
if (v->get.fv == -1)
continue;
SET_STRING_ELT(ans_names, i, mkChar(dict->var[i]->name));
if (v->type == NUMERIC) {
SET_VECTOR_ELT(ans, i, allocVector(REALSXP, N));
} else {
SET_VECTOR_ELT(ans, i, allocVector(STRSXP, N));
case_vals[v->fv].c =
(unsigned char *) R_alloc(v->width + 1, 1);
((char *) &case_vals[v->fv].c[0])[v->width] = '\0';
}
}
while(pfm_read_case(fh, case_vals, dict)) {
if (ncases == N) {
N *= 2;
for (i = 0; i < dict->nvar; i++) {
SEXP elt = VECTOR_ELT(ans, i);
elt = lengthgets(elt, N);
SET_VECTOR_ELT(ans, i, elt);
}
}
for (i = 0; i < dict->nvar; i++) {
struct variable *v = dict->var[i];
if (v->get.fv == -1)
continue;
if (v->type == NUMERIC) {
REAL(VECTOR_ELT(ans, i))[ncases] = case_vals[v->fv].f;
} else {
SET_STRING_ELT(VECTOR_ELT(ans, i), ncases,
mkChar((char *)case_vals[v->fv].c));
}
}
++ncases;
}
if (N != ncases) {
for (i = 0; i < dict->nvar; i++) {
SEXP elt = VECTOR_ELT(ans, i);
elt = lengthgets(elt, ncases);
SET_VECTOR_ELT(ans, i, elt);
}
}
fh_close_handle(fh);
/* get all the value labels */
PROTECT(val_labels = getSPSSvaluelabels(dict));
namesgets(val_labels, ans_names);
setAttrib(ans, install("label.table"), val_labels);
UNPROTECT(1);
/* get SPSS variable labels */
PROTECT(variable_labels = allocVector(STRSXP, dict->nvar));
nvar_label = 0;
for (i = 0; i < dict->nvar; i++) {
char *lab = dict->var[i]->label;
if (lab != NULL) {
nvar_label++;
SET_STRING_ELT(variable_labels, i, mkChar(lab));
}
}
if (nvar_label > 0) {
namesgets(variable_labels, ans_names);
setAttrib(ans, install("variable.labels"), variable_labels);
}
UNPROTECT(1);
/* report missingness */
PROTECT(miss_labels = getSPSSmissing(dict, &have_miss));
if(have_miss) {
namesgets(miss_labels, duplicate(ans_names));
setAttrib(ans, install("missings"), miss_labels);
}
UNPROTECT(1);
free_dictionary(dict);
setAttrib(ans, R_NamesSymbol, ans_names);
UNPROTECT(2);
return ans;
}
/*then returns an R data.frame that contain the RRA values fitting between timestamps startIn (non incl) and sendIn*/
SEXP importRRD(SEXP filenameIn, SEXP cfIn, SEXP startIn, SEXP endIn, SEXP stepIn) {
rrd_value_t *data;
const char *filename;
const char *cf;
char** ds_namv;
time_t start;
time_t end;
unsigned long step;
unsigned long ds_cnt;
int status;
int size;
int ds;
int i;
int timeStamp;
SEXP out;
SEXP vec;
SEXP nam;
SEXP rowNam;
SEXP cls;
filename = CHAR(asChar(filenameIn));
if (access(filename, F_OK) == -1) {
printf("file does not exist\n");
exit(0);
}
cf = CHAR(asChar(cfIn));
start = (time_t) asInteger(startIn);
end = (time_t) asInteger(endIn);
step = (unsigned long) asInteger(stepIn);
printf("calling rrdfetch\n");
status = rrd_fetch_r(filename, cf, &start, &end, &step, &ds_cnt, &ds_namv, &data);
if (status != 0 || data == NULL) {
printf("error running rrd_fetch_r\n");
if (data)
free(data);
if (ds_namv) {
for (int k = 0; k < sizeof(ds_namv)/sizeof(char*); k++) {
free(ds_namv[k]);
}
free(ds_namv);
}
exit(0);
}
printf("size of data %d start %d end %d step %d ds_cnt %d\n", sizeof(data)/sizeof(rrd_value_t), start, end, step, ds_cnt);
//turns out rrd_fetch does not include start in data
size = (end - start)/step - 1;
out = PROTECT(allocVector(VECSXP, ds_cnt + 1) );
vec = PROTECT(allocVector(INTSXP, size));
PROTECT(rowNam = allocVector(STRSXP, size));
//turns out rrd_fetch does not include start in data
timeStamp = start + step;
for (i = 0; i < size; i++) {
INTEGER(vec)[i] = timeStamp;
timeStamp += step;
}
SET_VECTOR_ELT(out, 0, vec);
setAttrib(out, R_RowNamesSymbol, vec);
PROTECT(nam = allocVector(STRSXP, ds_cnt + 1));
SET_STRING_ELT(nam, 0, mkChar("timestamp"));
for (ds = 0; ds < ds_cnt; ds++){
SET_STRING_ELT(nam, ds + 1, mkChar(ds_namv[ds]));
vec = PROTECT(allocVector(REALSXP, size));
for (i = 0; i < size; i++){
/*printf("iterating.. i = %d\n", i);*/
REAL(vec)[i] = data[ds + i*ds_cnt];
}
SET_VECTOR_ELT(out, ds + 1, vec);
}
PROTECT(cls = allocVector(STRSXP, 1)); // class attribute
SET_STRING_ELT(cls, 0, mkChar("data.frame"));
classgets(out, cls);
namesgets(out, nam);
free(data);
for (int k = 0; k < sizeof(ds_namv)/sizeof(char*); k++) {
free(ds_namv[k]);
}
free(ds_namv);
UNPROTECT(ds_cnt + 4);
return out;
}
SEXP redundant(SEXP m, SEXP h)
{
GetRNGstate();
if (! isString(m))
error("'m' must be character");
if (! isMatrix(m))
error("'m' must be matrix");
if (! isLogical(h))
error("'h' must be logical");
if (LENGTH(h) != 1)
error("'h' must be scalar");
SEXP m_dim;
PROTECT(m_dim = getAttrib(m, R_DimSymbol));
int nrow = INTEGER(m_dim)[0];
int ncol = INTEGER(m_dim)[1];
UNPROTECT(1);
#ifdef WOOF
printf("nrow = %d\n", nrow);
printf("ncol = %d\n", ncol);
#endif /* WOOF */
if (nrow < 2)
error("less than 2 rows, cannot be redundant");
if (ncol <= 2)
error("no cols in m[ , - c(1, 2)]");
for (int i = 0; i < nrow; i++) {
const char *foo = CHAR(STRING_ELT(m, i));
if (strlen(foo) != 1)
error("column one of 'm' not zero-or-one valued");
if (! (foo[0] == '0' || foo[0] == '1'))
error("column one of 'm' not zero-or-one valued");
}
if (! LOGICAL(h)[0])
for (int i = nrow; i < 2 * nrow; i++) {
const char *foo = CHAR(STRING_ELT(m, i));
if (strlen(foo) != 1)
error("column two of 'm' not zero-or-one valued");
if (! (foo[0] == '0' || foo[0] == '1'))
error("column two of 'm' not zero-or-one valued");
}
dd_set_global_constants();
/* note actual type of "value" is mpq_t (defined in cddmp.h) */
mytype value;
dd_init(value);
dd_MatrixPtr mf = dd_CreateMatrix(nrow, ncol - 1);
/* note our matrix has one more column than Fukuda's */
/* representation */
if(LOGICAL(h)[0])
mf->representation = dd_Inequality;
else
mf->representation = dd_Generator;
mf->numbtype = dd_Rational;
/* linearity */
for (int i = 0; i < nrow; i++) {
const char *foo = CHAR(STRING_ELT(m, i));
if (foo[0] == '1')
set_addelem(mf->linset, i + 1);
/* note conversion from zero-origin to one-origin indexing */
}
/* matrix */
for (int j = 1, k = nrow; j < ncol; j++)
for (int i = 0; i < nrow; i++, k++) {
const char *rat_str = CHAR(STRING_ELT(m, k));
if (mpq_set_str(value, rat_str, 10) == -1)
ERROR_WITH_CLEANUP_3("error converting string to GMP rational");
mpq_canonicalize(value);
dd_set(mf->matrix[i][j - 1], value);
/* note our matrix has one more column than Fukuda's */
}
dd_rowset impl_linset, redset;
dd_rowindex newpos;
dd_ErrorType err = dd_NoError;
dd_MatrixCanonicalize(&mf, &impl_linset, &redset, &newpos, &err);
if (err != dd_NoError) {
rr_WriteErrorMessages(err);
ERROR_WITH_CLEANUP_6("failed");
}
int mrow = mf->rowsize;
int mcol = mf->colsize;
if (mcol + 1 != ncol)
ERROR_WITH_CLEANUP_6("Cannot happen! computed matrix has"
" wrong number of columns");
#ifdef WOOF
printf("mrow = %d\n", mrow);
printf("mcol = %d\n", mcol);
#endif /* WOOF */
SEXP bar;
PROTECT(bar = allocMatrix(STRSXP, mrow, ncol));
/* linearity output */
for (int i = 0; i < mrow; i++)
if (set_member(i + 1, mf->linset))
SET_STRING_ELT(bar, i, mkChar("1"));
else
SET_STRING_ELT(bar, i, mkChar("0"));
/* note conversion from zero-origin to one-origin indexing */
/* matrix output */
for (int j = 1, k = mrow; j < ncol; j++)
for (int i = 0; i < mrow; i++, k++) {
dd_set(value, mf->matrix[i][j - 1]);
/* note our matrix has one more column than Fukuda's */
char *zstr = NULL;
zstr = mpq_get_str(zstr, 10, value);
SET_STRING_ELT(bar, k, mkChar(zstr));
free(zstr);
}
if (mf->representation == dd_Inequality) {
SEXP attr_name, attr_value;
PROTECT(attr_name = ScalarString(mkChar("representation")));
PROTECT(attr_value = ScalarString(mkChar("H")));
setAttrib(bar, attr_name, attr_value);
UNPROTECT(2);
}
if (mf->representation == dd_Generator) {
SEXP attr_name, attr_value;
PROTECT(attr_name = ScalarString(mkChar("representation")));
PROTECT(attr_value = ScalarString(mkChar("V")));
setAttrib(bar, attr_name, attr_value);
UNPROTECT(2);
}
int impl_size = set_card(impl_linset);
int red_size = set_card(redset);
int nresult = 1;
int iresult = 1;
SEXP baz = NULL;
if (impl_size > 0) {
PROTECT(baz = rr_set_fwrite(impl_linset));
nresult++;
}
SEXP qux = NULL;
if (red_size > 0) {
PROTECT(qux = rr_set_fwrite(redset));
nresult++;
}
SEXP fred = NULL;
{
PROTECT(fred = allocVector(INTSXP, nrow));
for (int i = 1; i <= nrow; i++)
INTEGER(fred)[i - 1] = newpos[i];
nresult++;
}
#ifdef WOOF
fprintf(stderr, "impl_size = %d\n", impl_size);
fprintf(stderr, "red_size = %d\n", red_size);
fprintf(stderr, "nresult = %d\n", nresult);
if (baz)
fprintf(stderr, "LENGTH(baz) = %d\n", LENGTH(baz));
if (qux)
fprintf(stderr, "LENGTH(qux) = %d\n", LENGTH(qux));
#endif /* WOOF */
SEXP result, resultnames;
PROTECT(result = allocVector(VECSXP, nresult));
PROTECT(resultnames = allocVector(STRSXP, nresult));
SET_STRING_ELT(resultnames, 0, mkChar("output"));
SET_VECTOR_ELT(result, 0, bar);
if (baz) {
SET_STRING_ELT(resultnames, iresult, mkChar("implied.linearity"));
SET_VECTOR_ELT(result, iresult, baz);
iresult++;
}
if (qux) {
SET_STRING_ELT(resultnames, iresult, mkChar("redundant"));
SET_VECTOR_ELT(result, iresult, qux);
iresult++;
}
{
SET_STRING_ELT(resultnames, iresult, mkChar("new.position"));
SET_VECTOR_ELT(result, iresult, fred);
iresult++;
}
namesgets(result, resultnames);
set_free(redset);
set_free(impl_linset);
free(newpos);
dd_FreeMatrix(mf);
dd_clear(value);
dd_free_global_constants();
PutRNGstate();
UNPROTECT(nresult + 2);
return result;
}
SEXP smartImportRRD(SEXP filenameIn){
time_t first;
time_t last;
time_t start;
time_t end;
time_t *startAr;
unsigned long curStep;
unsigned long ds_cnt;
unsigned long step;
int rraCnt;
int status;
int size;
int i;
int ds;
int j;
int timeStamp;
char **ds_namv;
const char *filename;
rrd_value_t *data;
rraInfo* rraInfoList;
rraInfo* rraInfoTmp;
rrd_info_t *rrdInfo;
SEXP out;
SEXP vec;
SEXP rraSexpList;
SEXP rraNames;
SEXP nam;
SEXP rowNam;
SEXP cls;
filename = CHAR(asChar(filenameIn));
if (access(filename, F_OK) == -1) {
printf("file does not exist\n");
exit(0);
}
printf("calling rrd_last\n");
last = rrd_last_r(filename);
printf("calling rrd_info\n");
rrdInfo = rrd_info_r(filename);
if (rrdInfo == NULL) {
printf("getting rrd info failed");
exit(0);
}
printf("calling getrrainfo\n");
rraInfoList = getRraInfo(rrdInfo, &rraCnt, &step);
if (rraInfoList == NULL) {
printf("getting rra info failed\n");
free(rrdInfo);
exit(0);
}
printf("rraCnt %d step %d last %d rraInfoList %p\n", rraCnt, step, last, rraInfoList);
printRraInfo(rraInfoList);
startAr = malloc(rraCnt * sizeof(time_t));
if (startAr == NULL) {
printf("memory allocation error");
free(rrdInfo);
freeRraInfo(rraInfoList);
exit(0);
}
for (i = 0; i < rraCnt; i++) {
startAr[i] = rrd_first_r(filename, i);
}
rraInfoTmp = rraInfoList;
PROTECT(rraNames = allocVector(STRSXP, rraCnt));
PROTECT(cls = allocVector(STRSXP, 1)); // class attribute
SET_STRING_ELT(cls, 0, mkChar("data.frame"));
out = PROTECT(allocVector(VECSXP, rraCnt));
i = 0;
printf("entering loop\n");
while (rraInfoTmp) {
start = startAr[i];
end = last;
curStep = step * rraInfoTmp->perRow;
status = rrd_fetch_r(filename, rraInfoTmp->cf, &start, &end, &curStep, &ds_cnt, &ds_namv, &data);
if (status != 0 || data == NULL) {
printf("error running rrd_fetch_r\n");
free(rrdInfo);
freeRraInfo(rraInfoList);
free(startAr);
if (data)
free(data);
if (ds_namv) {
for (int k = 0; k < sizeof(ds_namv)/sizeof(char*); k++) {
free(ds_namv[k]);
}
free(ds_namv);
}
//TODO unprotect how many times?
exit(0);
}
printf("size of data %d start %d end %d step %d ds_cnt %d\n", sizeof(data)/sizeof(rrd_value_t), start, end, curStep, ds_cnt);
fflush(stdout);
//rrd_fetch does not include start
size = (end - start)/curStep - 1;
printf("size %d\n", size);
rraSexpList = PROTECT(allocVector(VECSXP, ds_cnt + 1));
vec = PROTECT(allocVector(INTSXP, size));
PROTECT(rowNam = allocVector(STRSXP, size));
//rrd_fetch does not include start
timeStamp = start + curStep;
for (int j = 0; j < size; j++) {
INTEGER(vec)[j] = timeStamp;
timeStamp += curStep;
}
printf("setting row names\n");
SET_VECTOR_ELT(rraSexpList, 0, vec);
setAttrib(rraSexpList, R_RowNamesSymbol, vec);
PROTECT(nam = allocVector(STRSXP, ds_cnt + 1));
SET_STRING_ELT(nam, 0, mkChar("timestamp"));
//TODO stick to row/columns convention
for (ds = 0; ds < ds_cnt; ds++){
SET_STRING_ELT(nam, ds + 1, mkChar(ds_namv[ds]));
vec = PROTECT(allocVector(REALSXP, size));
for (j = 0; j < size; j++){
REAL(vec)[j] = data[ds + j*ds_cnt];
}
printf("adding ds vector to data frame\n");
SET_VECTOR_ELT(rraSexpList, ds + 1, vec);
}
classgets(rraSexpList, cls);
namesgets(rraSexpList, nam);
printf("adding data frame to out\n");
SET_VECTOR_ELT(out, i, rraSexpList);
char rraNameString[80];
char stepString[40];
sprintf(stepString, "%d", curStep);
strcpy(rraNameString, rraInfoTmp->cf);
strcat(rraNameString, stepString);
SET_STRING_ELT(rraNames, i, mkChar(rraNameString));
rraInfoTmp = rraInfoTmp->next;
i++;
free(data);
}
setAttrib(out, R_NamesSymbol, rraNames);
freeRraInfo(rraInfoList);
free(startAr);
free(rrdInfo);
for (int k = 0; k < sizeof(ds_namv)/sizeof(char*); k++) {
free(ds_namv[k]);
}
free(ds_namv);
UNPROTECT((ds_cnt + 2)*rraCnt + 3);
return out;
}
static SEXP FaceEnum(dd_MatrixPtr M)
{
PROTECT_WITH_INDEX(dimlist = R_NilValue, &dimidx);
PROTECT_WITH_INDEX(riplist = R_NilValue, &ripidx);
PROTECT_WITH_INDEX(activelist = R_NilValue, &activeidx);
dd_rowset R, S;
set_initialize(&R, M->rowsize);
set_initialize(&S, M->rowsize);
dd_ErrorType err = FaceEnumHelper(M, R, S);
set_free(R);
set_free(S);
if (err != dd_NoError) {
#ifdef MOO
switch (err) {
case dd_DimensionTooLarge:
fprintf(stderr, "err = dd_DimensionTooLarge\n");
break;
case dd_ImproperInputFormat:
fprintf(stderr, "err = dd_ImproperInputFormat\n");
break;
case dd_NegativeMatrixSize:
fprintf(stderr, "err = dd_NegativeMatrixSize\n");
break;
case dd_EmptyVrepresentation:
fprintf(stderr, "err = dd_EmptyVrepresentation\n");
break;
case dd_EmptyHrepresentation:
fprintf(stderr, "err = dd_EmptyHrepresentation\n");
break;
case dd_EmptyRepresentation:
fprintf(stderr, "err = dd_EmptyRepresentation\n");
break;
case dd_IFileNotFound:
fprintf(stderr, "err = dd_IFileNotFound\n");
break;
case dd_OFileNotOpen:
fprintf(stderr, "err = dd_OFileNotOpen\n");
break;
case dd_NoLPObjective:
fprintf(stderr, "err = dd_NoLPObjective\n");
break;
case dd_NoRealNumberSupport:
fprintf(stderr, "err = dd_NoRealNumberSupport\n");
break;
case dd_NotAvailForH:
fprintf(stderr, "err = dd_NotAvailForH\n");
break;
case dd_NotAvailForV:
fprintf(stderr, "err = dd_NotAvailForV\n");
break;
case dd_CannotHandleLinearity:
fprintf(stderr, "err = dd_CannotHandleLinearity\n");
break;
case dd_RowIndexOutOfRange:
fprintf(stderr, "err = dd_RowIndexOutOfRange\n");
break;
case dd_ColIndexOutOfRange:
fprintf(stderr, "err = dd_ColIndexOutOfRange\n");
break;
case dd_LPCycling:
fprintf(stderr, "err = dd_LPCycling\n");
break;
case dd_NumericallyInconsistent:
fprintf(stderr, "err = dd_NumericallyInconsistent\n");
break;
case dd_NoError:
fprintf(stderr, "err = dd_NoError\n");
break;
default:
fprintf(stderr, "err bogus, WTF????\n");
}
#endif /* MOO */
rr_WriteErrorMessages(err);
UNPROTECT(3);
return R_NilValue;
}
SEXP result;
SEXP resultnames;
PROTECT(result = allocVector(VECSXP, 3));
PROTECT(resultnames = allocVector(STRSXP, 3));
SET_STRING_ELT(resultnames, 0, mkChar("dimension"));
SET_STRING_ELT(resultnames, 1, mkChar("active.set"));
SET_STRING_ELT(resultnames, 2, mkChar("relative.interior.point"));
namesgets(result, resultnames);
SET_VECTOR_ELT(result, 0, PairToVectorList(dimlist));
SET_VECTOR_ELT(result, 1, PairToVectorList(activelist));
SET_VECTOR_ELT(result, 2, PairToVectorList(riplist));
UNPROTECT(5);
return result;
}
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 hitrun(SEXP alpha, SEXP initial, SEXP nbatch, SEXP blen, SEXP nspac,
SEXP origin, SEXP basis, SEXP amat, SEXP bvec, SEXP outmat, SEXP debug)
{
if (! isReal(alpha))
error("argument \"alpha\" must be type double");
if (! isReal(initial))
error("argument \"initial\" must be type double");
if (! isInteger(nbatch))
error("argument \"nbatch\" must be type integer");
if (! isInteger(blen))
error("argument \"blen\" must be type integer");
if (! isInteger(nspac))
error("argument \"nspac\" must be type integer");
if (! isReal(origin))
error("argument \"origin\" must be type double");
if (! isReal(basis))
error("argument \"basis\" must be type double");
if (! isReal(amat))
error("argument \"amat\" must be type double");
if (! isReal(bvec))
error("argument \"bvec\" must be type double");
if (! (isNull(outmat) | isReal(outmat)))
error("argument \"outmat\" must be type double or NULL");
if (! isLogical(debug))
error("argument \"debug\" must be logical");
if (! isMatrix(basis))
error("argument \"basis\" must be matrix");
if (! isMatrix(amat))
error("argument \"amat\" must be matrix");
if (! (isNull(outmat) | isMatrix(outmat)))
error("argument \"outmat\" must be matrix or NULL");
int dim_oc = LENGTH(alpha);
int dim_nc = LENGTH(initial);
int ncons = nrows(amat);
if (LENGTH(nbatch) != 1)
error("argument \"nbatch\" must be scalar");
if (LENGTH(blen) != 1)
error("argument \"blen\" must be scalar");
if (LENGTH(nspac) != 1)
error("argument \"nspac\" must be scalar");
if (LENGTH(origin) != dim_oc)
error("length(origin) != length(alpha)");
if (nrows(basis) != dim_oc)
error("nrow(basis) != length(alpha)");
if (ncols(basis) != dim_nc)
error("ncol(basis) != length(initial)");
if (ncols(amat) != dim_nc)
error("ncol(amat) != length(initial)");
if (LENGTH(bvec) != ncons)
error("length(bvec) != nrow(amat)");
if (LENGTH(debug) != 1)
error("argument \"debug\" must be scalar");
int dim_out = dim_oc;
if (! isNull(outmat)) {
dim_out = nrows(outmat);
if (ncols(outmat) != dim_oc)
error("ncol(outmat) != length(alpha)");
}
int int_nbatch = INTEGER(nbatch)[0];
int int_blen = INTEGER(blen)[0];
int int_nspac = INTEGER(nspac)[0];
int int_debug = LOGICAL(debug)[0];
double *dbl_star_alpha = REAL(alpha);
double *dbl_star_initial = REAL(initial);
double *dbl_star_origin = REAL(origin);
double *dbl_star_basis = REAL(basis);
double *dbl_star_amat = REAL(amat);
double *dbl_star_bvec = REAL(bvec);
int has_outmat = isMatrix(outmat);
double *dbl_star_outmat = 0;
if (has_outmat)
dbl_star_outmat = REAL(outmat);
if (int_nbatch <= 0)
error("argument \"nbatch\" must be positive");
if (int_blen <= 0)
error("argument \"blen\" must be positive");
if (int_nspac <= 0)
error("argument \"nspac\" must be positive");
check_finite(dbl_star_alpha, dim_oc, "alpha");
check_positive(dbl_star_alpha, dim_oc, "alpha");
check_finite(dbl_star_initial, dim_nc, "initial");
check_finite(dbl_star_origin, dim_oc, "origin");
check_finite(dbl_star_basis, dim_oc * dim_nc, "basis");
check_finite(dbl_star_amat, ncons * dim_nc, "amat");
check_finite(dbl_star_bvec, ncons, "bvec");
if (has_outmat)
check_finite(dbl_star_outmat, dim_out * dim_oc, "outmat");
double *state = (double *) R_alloc(dim_nc, sizeof(double));
double *proposal = (double *) R_alloc(dim_nc, sizeof(double));
double *batch_buffer = (double *) R_alloc(dim_out, sizeof(double));
double *out_buffer = (double *) R_alloc(dim_out, sizeof(double));
memcpy(state, dbl_star_initial, dim_nc * sizeof(double));
logh_setup(dbl_star_alpha, dbl_star_origin, dbl_star_basis, dim_oc, dim_nc);
double current_log_dens = logh(state);
out_setup(dbl_star_origin, dbl_star_basis, dbl_star_outmat, dim_oc, dim_nc,
dim_out, has_outmat);
SEXP result, resultnames, path, save_initial, save_final;
if (! int_debug) {
PROTECT(result = allocVector(VECSXP, 3));
PROTECT(resultnames = allocVector(STRSXP, 3));
} else {
PROTECT(result = allocVector(VECSXP, 11));
PROTECT(resultnames = allocVector(STRSXP, 11));
}
PROTECT(path = allocMatrix(REALSXP, dim_out, int_nbatch));
SET_VECTOR_ELT(result, 0, path);
PROTECT(save_initial = duplicate(initial));
SET_VECTOR_ELT(result, 1, save_initial);
UNPROTECT(2);
SET_STRING_ELT(resultnames, 0, mkChar("batch"));
SET_STRING_ELT(resultnames, 1, mkChar("initial"));
SET_STRING_ELT(resultnames, 2, mkChar("final"));
if (int_debug) {
SEXP spath, ppath, zpath, u1path, u2path, s1path, s2path, gpath;
int nn = int_nbatch * int_blen * int_nspac;
PROTECT(spath = allocMatrix(REALSXP, dim_nc, nn));
SET_VECTOR_ELT(result, 3, spath);
PROTECT(ppath = allocMatrix(REALSXP, dim_nc, nn));
SET_VECTOR_ELT(result, 4, ppath);
PROTECT(zpath = allocMatrix(REALSXP, dim_nc, nn));
SET_VECTOR_ELT(result, 5, zpath);
PROTECT(u1path = allocVector(REALSXP, nn));
SET_VECTOR_ELT(result, 6, u1path);
PROTECT(u2path = allocVector(REALSXP, nn));
SET_VECTOR_ELT(result, 7, u2path);
PROTECT(s1path = allocVector(REALSXP, nn));
SET_VECTOR_ELT(result, 8, s1path);
PROTECT(s2path = allocVector(REALSXP, nn));
SET_VECTOR_ELT(result, 9, s2path);
PROTECT(gpath = allocVector(REALSXP, nn));
SET_VECTOR_ELT(result, 10, gpath);
UNPROTECT(8);
SET_STRING_ELT(resultnames, 3, mkChar("current"));
SET_STRING_ELT(resultnames, 4, mkChar("proposal"));
SET_STRING_ELT(resultnames, 5, mkChar("z"));
SET_STRING_ELT(resultnames, 6, mkChar("u1"));
SET_STRING_ELT(resultnames, 7, mkChar("u2"));
SET_STRING_ELT(resultnames, 8, mkChar("s1"));
SET_STRING_ELT(resultnames, 9, mkChar("s2"));
SET_STRING_ELT(resultnames, 10, mkChar("log.green"));
}
namesgets(result, resultnames);
UNPROTECT(1);
GetRNGstate();
if (current_log_dens == R_NegInf)
error("log unnormalized density -Inf at initial state");
for (int ibatch = 0, k = 0; ibatch < int_nbatch; ibatch++) {
for (int i = 0; i < dim_out; i++)
batch_buffer[i] = 0.0;
for (int jbatch = 0; jbatch < int_blen; jbatch++) {
double proposal_log_dens;
for (int ispac = 0; ispac < int_nspac; ispac++) {
/* Note: should never happen! */
if (current_log_dens == R_NegInf)
error("log density -Inf at current state");
double u1 = R_NaReal;
double u2 = R_NaReal;
double smax = R_NaReal;
double smin = R_NaReal;
double z[dim_nc];
propose(state, proposal, dbl_star_amat, dbl_star_bvec,
dim_nc, ncons, z, &smax, &smin, &u1);
proposal_log_dens = logh(proposal);
int accept = FALSE;
if (proposal_log_dens != R_NegInf) {
if (proposal_log_dens >= current_log_dens) {
accept = TRUE;
} else {
double green = exp(proposal_log_dens
- current_log_dens);
u2 = unif_rand();
accept = u2 < green;
}
}
if (int_debug) {
int l = ispac + int_nspac * (jbatch + int_blen * ibatch);
int lbase = l * dim_nc;
SEXP spath = VECTOR_ELT(result, 3);
SEXP ppath = VECTOR_ELT(result, 4);
SEXP zpath = VECTOR_ELT(result, 5);
SEXP u1path = VECTOR_ELT(result, 6);
SEXP u2path = VECTOR_ELT(result, 7);
SEXP s1path = VECTOR_ELT(result, 8);
SEXP s2path = VECTOR_ELT(result, 9);
SEXP gpath = VECTOR_ELT(result, 10);
for (int lj = 0; lj < dim_nc; lj++) {
REAL(spath)[lbase + lj] = state[lj];
REAL(ppath)[lbase + lj] = proposal[lj];
REAL(zpath)[lbase + lj] = z[lj];
}
REAL(u1path)[l] = u1;
REAL(u2path)[l] = u2;
REAL(s1path)[l] = smin;
REAL(s2path)[l] = smax;
REAL(gpath)[l] = proposal_log_dens - current_log_dens;
}
if (accept) {
memcpy(state, proposal, dim_nc * sizeof(double));
current_log_dens = proposal_log_dens;
}
} /* end of inner loop (one iteration) */
outfun(state, out_buffer);
for (int j = 0; j < dim_out; j++)
batch_buffer[j] += out_buffer[j];
} /* end of middle loop (one batch) */
for (int j = 0; j < dim_out; j++, k++)
REAL(path)[k] = batch_buffer[j] / int_blen;
} /* end of outer loop */
PutRNGstate();
PROTECT(save_final = allocVector(REALSXP, dim_nc));
memcpy(REAL(save_final), state, dim_nc * sizeof(double));
SET_VECTOR_ELT(result, 2, save_final);
UNPROTECT(5);
return result;
}
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 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);
}
