void ScaleHMM::print_multi_iteration(int iteration)
{
//FILE_LOG(logDEBUG2) << __PRETTY_FUNCTION__;
if (this->verbosity>=1)
{
this->baumWelchTime_real = difftime(time(NULL),this->baumWelchStartTime_sec);
int bs = 86;
char buffer [86];
if (iteration % 20 == 0)
{
snprintf(buffer, bs, "%10s%20s%20s%15s", "Iteration", "log(P)", "dlog(P)", "Time in sec");
//FILE_LOG(logITERATION) << buffer;
Rprintf("%s\n", buffer);
}
if (iteration == 0)
{
snprintf(buffer, bs, "%10s%20s%20s%*d", "0", "-inf", "-", 15, this->baumWelchTime_real);
}
else if (iteration == 1)
{
snprintf(buffer, bs, "%*d%*f%20s%*d", 10, iteration, 20, this->logP, "inf", 15, this->baumWelchTime_real);
}
else
{
snprintf(buffer, bs, "%*d%*f%*f%*d", 10, iteration, 20, this->logP, 20, this->dlogP, 15, this->baumWelchTime_real);
}
//FILE_LOG(logITERATION) << buffer;
Rprintf("%s\n", buffer);
// Flush Rprintf statements to R console
R_FlushConsole();
}
}
SEXP doKeybd(SEXP eventRho, NewDevDesc *dd, R_KeyName rkey, char *keyname)
{
SEXP handler, skey, temp, result;
dd->gettingEvent = FALSE; /* avoid recursive calls */
handler = findVar(install("onKeybd"), eventRho);
if (TYPEOF(handler) == PROMSXP)
handler = eval(handler, eventRho);
result = NULL;
if (handler != R_UnboundValue && handler != R_NilValue) {
PROTECT(skey = allocVector(STRSXP, 1));
if (keyname) SET_STRING_ELT(skey, 0, mkChar(keyname));
else SET_STRING_ELT(skey, 0, mkChar(keynames[rkey]));
PROTECT(temp = lang2(handler, skey));
PROTECT(result = eval(temp, eventRho));
R_FlushConsole();
UNPROTECT(3);
}
dd->gettingEvent = TRUE;
return result;
}
void mqmscan(int Nind, int Nmark,int Npheno,int **Geno,int **Chromo, double **Dist, double **Pheno, int **Cofactors, int Backwards, int RMLorML,double Alfa,
int Emiter, double Windowsize,double Steps, double Stepmi,double Stepma,int NRUN,int out_Naug,int **INDlist, double **QTL, int re_estimate,
RqtlCrossType rqtlcrosstype,int domi,int verbose){
int cof_cnt=0;
MQMMarkerMatrix markers = newMQMMarkerMatrix(Nmark+1,Nind);
cvector cofactor = newcvector(Nmark);
vector mapdistance = newvector(Nmark);
MQMCrossType crosstype = determine_MQMCross(Nmark,Nind,(const int **)Geno,rqtlcrosstype);
change_coding(&Nmark, &Nind, Geno, markers, crosstype); // Change all the markers from R/qtl format to MQM internal
for (int i=0; i< Nmark; i++) {
mapdistance[i] = POSITIONUNKNOWN; // Mapdistances
mapdistance[i] = Dist[0][i];
cofactor[i] = MNOCOF; // Cofactors
if (Cofactors[0][i] == 1) {
cofactor[i] = MCOF; // Set cofactor
cof_cnt++;
}
if (Cofactors[0][i] == 2) {
cofactor[i] = MSEX;
cof_cnt++;
}
if (cof_cnt+10 > Nind){ fatal("Setting %d cofactors would leave less than 10 degrees of freedom.\n", cof_cnt); }
}
char reestimate = 'y';
if(re_estimate == 0) reestimate = 'n';
if (crosstype != CF2) { // Determine what kind of cross we have
if (verbose==1) Rprintf("INFO: Dominance setting ignored (setting dominance to 0)\n"); // Update dominance accordingly
domi = 0;
}
bool dominance=false;
if(domi != 0){ dominance=true; }
//WE HAVE EVERYTHING START WITH MAIN SCANNING FUNCTION
analyseF2(Nind, &Nmark, &cofactor, (MQMMarkerMatrix)markers, Pheno[(Npheno-1)], Backwards, QTL, &mapdistance, Chromo, NRUN, RMLorML, Windowsize,
Steps, Stepmi, Stepma, Alfa, Emiter, out_Naug, INDlist, reestimate, crosstype, dominance, verbose);
if (re_estimate) {
if (verbose==1) Rprintf("INFO: Sending back the re-estimated map used during the MQM analysis\n");
for (int i=0; i< Nmark; i++) {
Dist[0][i] = mapdistance[i];
}
}
if (Backwards) {
if (verbose==1) Rprintf("INFO: Sending back the model\n");
for (int i=0; i< Nmark; i++) { Cofactors[0][i] = cofactor[i]; }
}
if(verbose) Rprintf("INFO: All done in C returning to R\n");
#ifndef STANDALONE
R_CheckUserInterrupt(); /* check for ^C */
R_FlushConsole();
#endif
return;
} /* end of function mqmscan */
/* used in devWindows.c and cairoDevice */
void doKeybd(pDevDesc dd, R_KeyName rkey,
const char *keyname)
{
SEXP handler, skey, temp, result;
dd->gettingEvent = FALSE; /* avoid recursive calls */
PROTECT(handler = findVar(install(keybdHandler), dd->eventEnv));
if (TYPEOF(handler) == PROMSXP) {
handler = eval(handler, dd->eventEnv);
UNPROTECT(1); /* handler */
PROTECT(handler);
}
if (TYPEOF(handler) == CLOSXP) {
SEXP s_which = install("which");
defineVar(s_which, ScalarInteger(ndevNumber(dd)+1), dd->eventEnv);
PROTECT(skey = mkString(keyname ? keyname : keynames[rkey]));
PROTECT(temp = lang2(handler, skey));
PROTECT(result = eval(temp, dd->eventEnv));
defineVar(install("result"), result, dd->eventEnv);
UNPROTECT(3);
R_FlushConsole();
}
UNPROTECT(1); /* handler */
dd->gettingEvent = TRUE;
return;
}
/* used in devWindows.c and cairoDevice */
void doMouseEvent(pDevDesc dd, R_MouseEvent event,
int buttons, double x, double y)
{
int i;
SEXP handler, bvec, sx, sy, temp, result;
dd->gettingEvent = FALSE; /* avoid recursive calls */
handler = findVar(install(mouseHandlers[event]), dd->eventEnv);
if (TYPEOF(handler) == PROMSXP)
handler = eval(handler, dd->eventEnv);
if (TYPEOF(handler) == CLOSXP) {
defineVar(install("which"), ScalarInteger(ndevNumber(dd)+1), dd->eventEnv);
PROTECT(bvec = allocVector(INTSXP, 3));
i = 0;
if (buttons & leftButton) INTEGER(bvec)[i++] = 0;
if (buttons & middleButton) INTEGER(bvec)[i++] = 1;
if (buttons & rightButton) INTEGER(bvec)[i++] = 2;
SETLENGTH(bvec, i);
PROTECT(sx = ScalarReal( (x - dd->left) / (dd->right - dd->left) ));
PROTECT(sy = ScalarReal((y - dd->bottom) / (dd->top - dd->bottom) ));
PROTECT(temp = lang4(handler, bvec, sx, sy));
PROTECT(result = eval(temp, dd->eventEnv));
defineVar(install("result"), result, dd->eventEnv);
UNPROTECT(5);
R_FlushConsole();
}
dd->gettingEvent = TRUE;
return;
}
void display_progress_bar() {
if ( !is_display_on() )
return;
REprintf("0% 10 20 30 40 50 60 70 80 90 100%\n");
REprintf("|----|----|----|----|----|----|----|----|----|----|\n");
R_FlushConsole();
}
void ScaleHMM::print_uni_iteration(int iteration)
{
//FILE_LOG(logDEBUG2) << __PRETTY_FUNCTION__;
this->EMTime_real = difftime(time(NULL),this->EMStartTime_sec);
int bs = 106;
char buffer [106];
if (iteration % 20 == 0)
{
snprintf(buffer, bs, "%10s%20s%20s%20s%15s", "Iteration", "log(P)", "dlog(P)", "Diff in posterior", "Time in sec");
//FILE_LOG(logITERATION) << buffer;
Rprintf("%s\n", buffer);
}
if (iteration == 0)
{
snprintf(buffer, bs, "%10s%20s%20s%20s%*d", "0", "-inf", "-", "-", 15, this->EMTime_real);
}
else if (iteration == 1)
{
snprintf(buffer, bs, "%*d%*f%20s%*f%*d", 10, iteration, 20, this->logP, "inf", 20, this->sumdiff_posterior, 15, this->EMTime_real);
}
else
{
snprintf(buffer, bs, "%*d%*f%*f%*f%*d", 10, iteration, 20, this->logP, 20, this->dlogP, 20, this->sumdiff_posterior, 15, this->EMTime_real);
}
//FILE_LOG(logITERATION) << buffer;
Rprintf("%s\n", buffer);
// Flush Rprintf statements to R console
R_FlushConsole();
}
void progress(int p, int eta) {
// called from thread 0 only
// p between 0 and 100
// eta in seconds
// Initialized the first time it is called with p>0
// Must be called at the end with p==100 to finish off and reset
// If it's called twice at the end with p=100, that's ok
// REprinf to avoid Rprintf's call to R_CheckUserInterrupt() every 100 lines, issue #2457
// It's the R_CheckUserInterrupt() that has caused crashes before when called from OpenMP parallel region
// even when called only from master thread. Update: can now retry within critical.
// fwrite.c has some comments about how it might be possible to call R_CheckUserInterrupt() here so that
// a long running fread can be stopped by user with Ctrl-C (or ESC on Windows).
// Could try R_ProcessEvents() too as per
// https://cran.r-project.org/bin/windows/base/rw-FAQ.html#The-console-freezes-when-my-compiled-code-is-running
// No use of \r to avoid bug in RStudio, linked in the same issue #2457
// # nocov start
static int displayed = -1; // -1 means not yet displayed, otherwise [0,50] '=' are displayed
static char bar[] = "================================================== "; // 50 marks for each 2%
if (displayed==-1) {
if (eta<3 || p>50) return;
#pragma omp critical
{
REprintf("|--------------------------------------------------|\n|");
R_FlushConsole();
}
displayed = 0;
}
p/=2;
int toPrint = p-displayed;
if (toPrint==0) return;
bar[toPrint] = '\0';
#pragma omp critical
{
REprintf("%s", bar);
bar[toPrint] = '=';
displayed = p;
if (p==50) {
REprintf("|\n");
displayed = -1;
}
R_FlushConsole();
}
// # nocov end
}
void progress(double p, double eta) {
Rprintf("\rRead %.0f%%. ETA %02d:%02d ", p, (int)eta/60, (int)eta%60);
// See comments in fwrite.c for how we might in future be able to R_CheckUserInterrupt() here.
// ( Had crashes with R_CheckUserInterrupt() even when called only from master thread, to overcome. )
#ifdef WIN32
R_FlushConsole();
// Could try R_ProcessEvents() too as per
// https://cran.r-project.org/bin/windows/base/rw-FAQ.html#The-console-freezes-when-my-compiled-code-is-running
#endif
}
void end_display() {
if ( !is_display_on() )
return;
if ( ! is_aborted() ) {
// compute the remaining ticks and display them
int remaining = 50 - _compute_nb_ticks(_last_displayed);
_display_ticks(remaining);
}
REprintf("|\n");
R_FlushConsole();
}
void setFinalNrow(size_t nrow) {
// TODO realloc
if (length(DT)) {
if (nrow == dtnrows)
return;
for (int i=0; i<LENGTH(DT); i++) {
SETLENGTH(VECTOR_ELT(DT,i), nrow);
SET_TRUELENGTH(VECTOR_ELT(DT,i), nrow);
}
}
R_FlushConsole(); // # 2481. Just a convenient place; nothing per se to do with setFinalNrow()
}
int main(int argc, char **argv)
{
char *progname = argv[0], *line, *newline();
int i, j, k, n_prob, got_opt();
double total_kinship();
vertex *top, *bot;
blankline = &whereblank;
line_no=0;
for (line=newline(); line && line != blankline; line = newline())
{
if (sscanf(line,"%d%d%d",&i,&j,&k) != 3)
{
error("\n %s(%d): cannot read triplet",progname,line_no);
}
if (i > 0) bot = find_vertex(i);
if (j > 0)
{
top = find_vertex(j);
if (!connected(bot,top)) make_edge(bot,top);
}
if (k > 0)
{
top = find_vertex(k);
if (!connected(bot,top)) make_edge(bot,top);
}
}
for ( ; line; line=newline())
{
while (line && line == blankline) line=newline();
for (no_probands(),n_prob=0 ; line && line != blankline; line=newline())
{
if (sscanf(line,"%d",&i) != 1)
{
error("\n %s(%d): cannot read integer",progname,line_no);
}
if (i > 0)
{
bot=find_vertex(i);
if (new_proband(bot)) n_prob +=1;
}
}
Rprintf("%9.3f",100000.0*total_kinship()/n_prob/(n_prob-1)*2.0);
Rprintf("\n\n");
R_FlushConsole();
}
R_ClearerrConsole();
return(0);
}
/*********************
void WtCDSample
Using the parameters contained in the array theta, obtain the
network statistics for a sample of size samplesize. burnin is the
initial number of Markov chain steps before sampling anything
and interval is the number of MC steps between successive
networks in the sample. Put all the sampled statistics into
the networkstatistics array.
*********************/
WtMCMCStatus WtCDSample(WtMHproposal *MHp,
double *theta, double *networkstatistics,
int samplesize, int *CDparams, Vertex *undotail, Vertex *undohead, double *undoweight, int fVerbose,
WtNetwork *nwp, WtModel *m, double *extraworkspace){
/*********************
networkstatistics are modified in groups of m->n_stats, and they
reflect the CHANGE in the values of the statistics from the
original (observed) network. Thus, when we begin, the initial
values of the first group of m->n_stats networkstatistics should
all be zero
*********************/
/*for (j=0; j < m->n_stats; j++) */
/* networkstatistics[j] = 0.0; */
/* Rprintf("\n"); */
/* for (j=0; j < m->n_stats; j++){ */
/* Rprintf("j %d %f\n",j,networkstatistics[j]); */
/* } */
/* Rprintf("\n"); */
int staken=0;
/* Now sample networks */
unsigned int i=0, sattempted=0;
while(i<samplesize){
if(WtCDStep(MHp, theta, networkstatistics, CDparams, &staken, undotail, undohead, undoweight,
fVerbose, nwp, m, extraworkspace)!=WtMCMC_OK)
return WtMCMC_MH_FAILED;
#ifdef Win32
if( ((100*i) % samplesize)==0 && samplesize > 500){
R_FlushConsole();
R_ProcessEvents();
}
#endif
networkstatistics += m->n_stats;
i++;
sattempted++;
}
if (fVerbose){
Rprintf("Sampler accepted %7.3f%% of %d proposed steps.\n",
staken*100.0/(1.0*sattempted*CDparams[0]), sattempted*CDparams[0]);
}
return WtMCMC_OK;
}
time_t interact(time_t itime)
{
#ifdef RPRINT
time_t ntime = time(NULL);
if(ntime - itime > 1) {
R_FlushConsole();
R_CheckUserInterrupt();
#if (defined(HAVE_AQUA) || defined(Win32) || defined(Win64))
R_ProcessEvents();
#endif
itime = ntime;
}
#endif
return itime;
}
char *newline()
{
int i, blank;
if (!fgets(line_buff,MAXLINE,stdin)) return(NULL);
while (line_buff[0] == '%')
{
if (line_buff[1] == '#') Rprintf("%%# %6.3f (0.000 on PC)\n",cpu_time());
else if (line_buff[1] =='%') Rprintf("%s",line_buff);
R_FlushConsole();
if (!fgets(line_buff,MAXLINE,stdin)) return(NULL);
}
for (i=0, blank=1; line_buff[i] != '\n' && blank; i++)
blank = blank && (line_buff[i] == '\t' || line_buff[i] == ' ');
if (blank) return(blankline);
return(line_buff);
}
/*********************
void WtMCMCSample
Using the parameters contained in the array theta, obtain the
network statistics for a sample of size samplesize. burnin is the
initial number of Markov chain steps before sampling anything
and interval is the number of MC steps between successive
networks in the sample. Put all the sampled statistics into
the networkstatistics array.
*********************/
WtMCMCStatus WtCDSample(WtMHproposal *MHp,
double *theta, double *networkstatistics,
int samplesize, int nsteps, Vertex *undotail, Vertex *undohead, double *undoweight, int fVerbose,
WtNetwork *nwp, WtModel *m) {
int i, j;
/*********************
networkstatistics are modified in groups of m->n_stats, and they
reflect the CHANGE in the values of the statistics from the
original (observed) network. Thus, when we begin, the initial
values of the first group of m->n_stats networkstatistics should
all be zero
*********************/
/*for (j=0; j < m->n_stats; j++) */
/* networkstatistics[j] = 0.0; */
/* Rprintf("\n"); */
/* for (j=0; j < m->n_stats; j++){ */
/* Rprintf("j %d %f\n",j,networkstatistics[j]); */
/* } */
/* Rprintf("\n"); */
/* Now sample networks */
for (i=0; i < samplesize; i++){
if(WtCDStep(MHp, theta, networkstatistics, nsteps, undotail, undohead, undoweight,
fVerbose, nwp, m)!=WtMCMC_OK)
return WtMCMC_MH_FAILED;
#ifdef Win32
if( ((100*i) % samplesize)==0 && samplesize > 500){
R_FlushConsole();
R_ProcessEvents();
}
#endif
networkstatistics += m->n_stats;
}
return WtMCMC_OK;
}
SEXP doMouseEvent(SEXP eventRho, NewDevDesc *dd, R_MouseEvent event,
int buttons, double x, double y)
{
int i;
SEXP handler, bvec, sx, sy, temp, result;
dd->gettingEvent = FALSE; /* avoid recursive calls */
handler = findVar(install(mouseHandlers[event]), eventRho);
if (TYPEOF(handler) == PROMSXP)
handler = eval(handler, eventRho);
result = NULL;
if (handler != R_UnboundValue && handler != R_NilValue) {
PROTECT(bvec = allocVector(INTSXP, 3));
i = 0;
if (buttons & leftButton) INTEGER(bvec)[i++] = 0;
if (buttons & middleButton) INTEGER(bvec)[i++] = 1;
if (buttons & rightButton) INTEGER(bvec)[i++] = 2;
SETLENGTH(bvec, i);
PROTECT(sx = allocVector(REALSXP, 1));
REAL(sx)[0] = (x - dd->left) / (dd->right - dd->left);
PROTECT(sy = allocVector(REALSXP, 1));
REAL(sy)[0] = (y - dd->bottom) / (dd->top - dd->bottom);
PROTECT(temp = lang4(handler, bvec, sx, sy));
PROTECT(result = eval(temp, eventRho));
R_FlushConsole();
UNPROTECT(5);
}
dd->gettingEvent = TRUE;
return result;
}
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);
}
/*********************
MCMCStatus MCMCSample
Using the parameters contained in the array theta, obtain the
network statistics for a sample of size samplesize. burnin is the
initial number of Markov chain steps before sampling anything
and interval is the number of MC steps between successive
networks in the sample. Put all the sampled statistics into
the networkstatistics array.
*********************/
MCMCStatus MCMCSample(MHproposal *MHp,
double *theta, double *networkstatistics,
int samplesize, int burnin,
int interval, int fVerbose, int nmax,
Network *nwp, Model *m){
int staken, tottaken;
int i, j;
/*********************
networkstatistics are modified in groups of m->n_stats, and they
reflect the CHANGE in the values of the statistics from the
original (observed) network. Thus, when we begin, the initial
values of the first group of m->n_stats networkstatistics should
all be zero
*********************/
/*for (j=0; j < m->n_stats; j++) */
/* networkstatistics[j] = 0.0; */
/* Rprintf("\n"); */
/* for (j=0; j < m->n_stats; j++){ */
/* Rprintf("j %d %f\n",j,networkstatistics[j]); */
/* } */
/* Rprintf("\n"); */
/*********************
Burn in step.
*********************/
/* Catch more edges than we can return */
if(MetropolisHastings(MHp, theta, networkstatistics, burnin, &staken,
fVerbose, nwp, m)!=MCMC_OK)
return MCMC_MH_FAILED;
if(nmax!=0 && nwp->nedges >= nmax-1){
return MCMC_TOO_MANY_EDGES;
}
/* if (fVerbose){
Rprintf(".");
} */
if (samplesize>1){
staken = 0;
tottaken = 0;
/* Now sample networks */
for (i=1; i < samplesize; i++){
/* Set current vector of stats equal to previous vector */
for (j=0; j<m->n_stats; j++){
networkstatistics[j+m->n_stats] = networkstatistics[j];
}
networkstatistics += m->n_stats;
/* This then adds the change statistics to these values */
/* Catch massive number of edges caused by degeneracy */
if(MetropolisHastings(MHp, theta, networkstatistics, interval, &staken,
fVerbose, nwp, m)!=MCMC_OK)
return MCMC_MH_FAILED;
if(nmax!=0 && nwp->nedges >= nmax-1){
return MCMC_TOO_MANY_EDGES;
}
tottaken += staken;
#ifdef Win32
if( ((100*i) % samplesize)==0 && samplesize > 500){
R_FlushConsole();
R_ProcessEvents();
}
#endif
}
/*********************
Below is an extremely crude device for letting the user know
when the chain doesn't accept many of the proposed steps.
*********************/
if (fVerbose){
if (samplesize > 0 && interval > LONG_MAX / samplesize) {
// overflow
Rprintf("Sampler accepted %7.3f%% of %d proposed steps.\n",
tottaken*100.0/(1.0*interval*samplesize), interval, samplesize);
} else {
Rprintf("Sampler accepted %7.3f%% of %d proposed steps.\n",
tottaken*100.0/(1.0*interval*samplesize), interval*samplesize);
}
}
}else{
if (fVerbose){
Rprintf("Sampler accepted %7.3f%% of %d proposed steps.\n",
staken*100.0/(1.0*burnin), burnin);
}
}
return MCMC_OK;
}
/*********************
void MCMCSamplePhase12
Using the parameters contained in the array theta, obtain the
network statistics for a sample of size samplesize. burnin is the
initial number of Markov chain steps before sampling anything
and interval is the number of MC steps between successive
networks in the sample. Put all the sampled statistics into
the networkstatistics array.
*********************/
void MCMCSamplePhase12(MHproposal *MHp,
double *theta, double gain, double *meanstats, int nphase1, int nsubphases, double *networkstatistics,
int samplesize, int burnin,
int interval, int fVerbose,
Network *nwp, Model *m){
int staken, tottaken, ptottaken;
int i, j, iter=0;
/*Rprintf("nsubphases %d\n", nsubphases); */
/*if (fVerbose)
Rprintf("The number of statistics is %i and the total samplesize is %d\n",
m->n_stats,samplesize);*/
/*********************
networkstatistics are modified in groups of m->n_stats, and they
reflect the CHANGE in the values of the statistics from the
original (observed) network. Thus, when we begin, the initial
values of the first group of m->n_stats networkstatistics should
all be zero
*********************/
double *ubar, *u2bar, *aDdiaginv;
ubar = (double *)malloc( m->n_stats * sizeof(double));
u2bar = (double *)malloc( m->n_stats * sizeof(double));
aDdiaginv = (double *)malloc( m->n_stats * sizeof(double));
for (j=0; j < m->n_stats; j++){
networkstatistics[j] = -meanstats[j];
ubar[j] = 0.0;
u2bar[j] = 0.0;
}
/*********************
Burn in step. While we're at it, use burnin statistics to
prepare covariance matrix for Mahalanobis distance calculations
in subsequent calls to M-H
*********************/
/*Rprintf("MCMCSampleDyn pre burnin numdissolve %d\n", *numdissolve); */
staken = 0;
Rprintf("Starting burnin of %d steps\n", burnin);
MetropolisHastings (MHp, theta,
networkstatistics, burnin, &staken,
fVerbose,
nwp, m);
Rprintf("Phase 1: %d steps (interval = %d)\n", nphase1,interval);
/* Now sample networks */
for (i=0; i <= nphase1; i++){
MetropolisHastings (MHp, theta,
networkstatistics, interval, &staken,
fVerbose,
nwp, m);
if(i > 0){
for (j=0; j<m->n_stats; j++){
ubar[j] += networkstatistics[j];
u2bar[j] += networkstatistics[j]*networkstatistics[j];
/* Rprintf("j %d ubar %f u2bar %f ns %f\n", j, ubar[j], u2bar[j], */
/* networkstatistics[j]); */
}
}
}
if (fVerbose){
Rprintf("Returned from Phase 1\n");
Rprintf("\n gain times inverse variances:\n");
}
for (j=0; j<m->n_stats; j++){
aDdiaginv[j] = u2bar[j]-ubar[j]*ubar[j]/(1.0*nphase1);
if( aDdiaginv[j] > 0.0){
aDdiaginv[j] = nphase1*gain/aDdiaginv[j];
}else{
aDdiaginv[j]=0.00001;
}
if (fVerbose){ Rprintf(" %f", aDdiaginv[j]);}
}
if (fVerbose){ Rprintf("\n"); }
staken = 0;
tottaken = 0;
ptottaken = 0;
if (fVerbose){
Rprintf("Phase 2: (samplesize = %d)\n", samplesize);
}
/* Now sample networks */
for (i=1; i < samplesize; i++){
MetropolisHastings (MHp, theta,
networkstatistics, interval, &staken,
fVerbose,
nwp, m);
/* Update theta0 */
/*Rprintf("initial:\n"); */
for (j=0; j<m->n_stats; j++){
theta[j] -= aDdiaginv[j] * networkstatistics[j];
}
/*Rprintf("\n"); */
/* if (fVerbose){ Rprintf("nsubphases %d i %d\n", nsubphases, i); } */
if (i==(nsubphases)){
nsubphases = trunc(nsubphases*2.52) + 1;
if (fVerbose){
iter++;
Rprintf("End of iteration %d; Updating the number of sub-phases to be %d\n",iter,nsubphases);
}
for (j=0; j<m->n_stats; j++){
aDdiaginv[j] /= 2.0;
if (fVerbose){Rprintf("theta_%d = %f; change statistic[%d] = %f\n",
j+1, theta[j], j+1, networkstatistics[j]);}
/* if (fVerbose){ Rprintf(" %f statsmean %f", theta[j],(networkstatistics[j]-meanstats[j])); } */
}
if (fVerbose){ Rprintf("\n"); }
}
/* Set current vector of stats equal to previous vector */
for (j=0; j<m->n_stats; j++){
/* networkstatistics[j] -= meanstats[j]; */
networkstatistics[j+m->n_stats] = networkstatistics[j];
}
networkstatistics += m->n_stats;
/* if (fVerbose){ Rprintf("step %d from %d:\n",i, samplesize);} */
/* This then adds the change statistics to these values */
tottaken += staken;
#ifdef Win32
if( ((100*i) % samplesize)==0 && samplesize > 500){
R_FlushConsole();
R_ProcessEvents();
}
#endif
if (fVerbose){
if( ((3*i) % samplesize)==0 && samplesize > 500){
Rprintf("Sampled %d from Metropolis-Hastings\n", i);}
}
if( ((3*i) % samplesize)==0 && tottaken == ptottaken){
ptottaken = tottaken;
Rprintf("Warning: Metropolis-Hastings algorithm has accepted only "
"%d steps out of a possible %d\n", ptottaken-tottaken, i);
}
/* Rprintf("Sampled %d from %d\n", i, samplesize); */
/*********************
Below is an extremely crude device for letting the user know
when the chain doesn't accept many of the proposed steps.
*********************/
/* if (fVerbose){ */
/* Rprintf("Metropolis-Hastings accepted %7.3f%% of %d steps.\n", */
/* tottaken*100.0/(1.0*interval*samplesize), interval*samplesize); */
/* } */
/* }else{ */
/* if (fVerbose){ */
/* Rprintf("Metropolis-Hastings accepted %7.3f%% of %d steps.\n", */
/* staken*100.0/(1.0*burnin), burnin); */
/* } */
}
/* Rprintf("netstats: %d\n", samplesize); */
/* for (i=0; i < samplesize; i++){ */
/* for (j=0; j < m->n_stats; j++){ */
/* Rprintf("%f ", networkstatistics[j+(m->n_stats)*(i)]); */
/* } */
/* Rprintf("\n"); */
/* } */
if (fVerbose){
Rprintf("Phase 3: MCMC-Newton-Raphson\n");
}
free(ubar);
free(u2bar);
}
int
partition(int nodenum, pNode splitnode, double *sumrisk, int n1, int n2,
int minsize, int split_Rule, double alpha, int bucketnum, int bucketMax,
double train_to_est_ratio)
{
pNode me;
double tempcp;
int i, j, k;
double tempcp2;
double left_risk, right_risk;
int left_split, right_split;
double twt, ttr;
int nleft, nright;
int n;
int min_node_size = minsize;
FILE* fptr;
me = splitnode;
n = n2 - n1; /* total number of observations */
me->id = nodenum;
//#ifdef DEBUG
//fptr=fopen("C:\\Users\\vikasr\\Documents\\debug_text.txt","w");
//fprintf(fptr,"test print\n");
//fclose(fptr);
R_FlushConsole();
//Rprintf("test print\n");
//R_ShowMessage("R_show_message\n");
//#endif
if (nodenum > 1) {
twt = 0;
ttr = 0;
k = 0;
for (i = n1; i < n2; i++) {
j = ct.sorts[0][i]; /* any variable would do, use first */
if (j < 0)
j = -(1 + j); /* if missing, value = -(1+ true index) */
ct.wtemp[k] = ct.wt[j];
ct.trtemp[k] = ct.treatment[j];
ct.ytemp[k] = ct.ydata[j];
twt += ct.wt[j];
ttr += ct.treatment[j] * ct.wt[j];
k++;
}
if (split_Rule == 1) {
// tot
(*ct_eval) (n, ct.ytemp, me->response_est, me->controlMean, me->treatMean,
&(me->risk), ct.wtemp, ct.trtemp, ct.max_y, ct.propensity);
} else if (split_Rule == 2) {
// ct
(*ct_eval) (n, ct.ytemp, me->response_est, me->controlMean, me->treatMean,
&(me->risk), ct.wtemp, ct.trtemp, ct.max_y, alpha, train_to_est_ratio);
} else if (split_Rule == 3) {
// fit
(*ct_eval) (n, ct.ytemp, me->response_est, me->controlMean, me->treatMean,
&(me->risk), ct.wtemp, ct.trtemp, ct.max_y, alpha, train_to_est_ratio);
} else if (split_Rule == 4) {
//tstats
(*ct_eval) (n, ct.ytemp, me->response_est, me->controlMean, me->treatMean,
&(me->risk), ct.wtemp, ct.trtemp, ct.max_y, alpha, train_to_est_ratio);
} else if (split_Rule == 5) {
// totD
(*ct_eval) (n, ct.ytemp, me->response_est, me->controlMean, me->treatMean,
&(me->risk), ct.wtemp, ct.trtemp, ct.max_y, ct.propensity);
} else if (split_Rule == 6) {
// CTD
(*ct_eval) (n, ct.ytemp, me->response_est, me->controlMean, me->treatMean,
&(me->risk), ct.wtemp, ct.trtemp, ct.max_y, alpha, train_to_est_ratio);
} else if (split_Rule == 7) {
//fitD
(*ct_eval) (n, ct.ytemp, me->response_est, me->controlMean, me->treatMean,
&(me->risk), ct.wtemp, ct.trtemp, ct.max_y, alpha, train_to_est_ratio);
} else if (split_Rule == 8) {
//tstatsD
(*ct_eval) (n, ct.ytemp, me->response_est, me->controlMean, me->treatMean,
&(me->risk), ct.wtemp, ct.trtemp, ct.max_y, alpha, train_to_est_ratio);
} else if (split_Rule == 9) {
// user (temporarily set as CT)
(*ct_eval) (n, ct.ytemp, me->response_est, me->controlMean, me->treatMean,
&(me->risk), ct.wtemp, ct.trtemp, ct.max_y, alpha, train_to_est_ratio);
} else if (split_Rule == 10) {
// userD (temporarily set as CTD)
(*ct_eval) (n, ct.ytemp, me->response_est, me->controlMean, me->treatMean,
&(me->risk), ct.wtemp, ct.trtemp, ct.max_y, alpha, train_to_est_ratio);
}else if (split_Rule == 11) {
// policy (temporarily set as CTD)
(*ct_eval) (n, ct.ytemp, me->response_est, me->controlMean, me->treatMean,
&(me->risk), ct.wtemp, ct.trtemp, ct.max_y, alpha, train_to_est_ratio);
}else if (split_Rule == 12) {
// policyD (temporarily set as CTD)
(*ct_eval) (n, ct.ytemp, me->response_est, me->controlMean, me->treatMean,
&(me->risk), ct.wtemp, ct.trtemp, ct.max_y, alpha, train_to_est_ratio);
}
me->num_obs = n;
me->sum_wt = twt;
me->sum_tr = ttr;
tempcp = me->risk;
if (tempcp > me->complexity)
tempcp = me->complexity;
} else
tempcp = me->risk;
/*
* Can I quit now ?
*/
if (me->num_obs < ct.min_split || tempcp <= ct.alpha || nodenum > ct.maxnode) {
me->complexity = ct.alpha;
*sumrisk = me->risk;
/*
* make sure the split doesn't have random pointers to somewhere
* i.e., don't trust that whoever allocated memory set it to zero
*/
me->leftson = (pNode) NULL;
me->rightson = (pNode) NULL;
me->primary = (pSplit) NULL;
me->surrogate = (pSplit) NULL;
return 0;
}
/*
* Guess I have to do the split
*/
bsplit(me, n1, n2, min_node_size, split_Rule, alpha, bucketnum, bucketMax, train_to_est_ratio);
if (!me->primary) {
/*
* This is rather rare -- but I couldn't find a split worth doing
*/
me->complexity = ct.alpha;
me->leftson = (pNode) NULL;
me->rightson = (pNode) NULL;
me->primary = (pSplit) NULL;
me->surrogate = (pSplit) NULL;
*sumrisk = me->risk;
return 0;
}
#ifdef DEBUG
print_tree(me, 4);
#endif
if (ct.maxsur > 0)
surrogate(me, n1, n2);
else
me->surrogate = (pSplit) NULL;
nodesplit(me, nodenum, n1, n2, &nleft, &nright);
/*
* split the leftson
*/
me->leftson = (pNode) CALLOC(1, nodesize);
(me->leftson)->parent = me;
(me->leftson)->complexity = tempcp - ct.alpha;
left_split = partition(2 * nodenum, me->leftson, &left_risk, n1, n1 + nleft,
min_node_size, split_Rule, alpha, bucketnum, bucketMax,
train_to_est_ratio);
/*
* Update my estimate of cp, and split the right son.
*/
tempcp = (me->risk - left_risk) / (left_split + 1);
tempcp2 = (me->risk - (me->leftson)->risk);
if (tempcp < tempcp2)
tempcp = tempcp2;
if (tempcp > me->complexity)
tempcp = me->complexity;
me->rightson = (pNode) CALLOC(1, nodesize);
(me->rightson)->parent = me;
(me->rightson)->complexity = tempcp - ct.alpha;
right_split = partition(1 + 2 * nodenum, me->rightson, &right_risk,
n1 + nleft, n1 + nleft + nright, min_node_size, split_Rule, alpha,
bucketnum, bucketMax, train_to_est_ratio);
/*
* Now calculate my actual C.P., which depends on children nodes, and
* on grandchildren who do not collapse before the children.
* The calculation is done assuming that I am the top node of the
* whole tree, an assumption to be fixed up later.
*/
tempcp = (me->risk - (left_risk + right_risk)) /
(left_split + right_split + 1);
/* Who goes first -- minimum of tempcp, leftson, and rightson */
if ((me->rightson)->complexity > (me->leftson)->complexity) {
if (tempcp > (me->leftson)->complexity) {
/* leftson collapses first */
left_risk = (me->leftson)->risk;
left_split = 0;
tempcp = (me->risk - (left_risk + right_risk)) /
(left_split + right_split + 1);
if (tempcp > (me->rightson)->complexity) {
/* right one goes too */
right_risk = (me->rightson)->risk;
right_split = 0;
}
}
} else if (tempcp > (me->rightson)->complexity) {
/* right hand child goes first */
right_split = 0;
right_risk = (me->rightson)->risk;
tempcp = (me->risk - (left_risk + right_risk)) /
(left_split + right_split + 1);
if (tempcp > (me->leftson)->complexity) {
/* left one goes too */
left_risk = (me->leftson)->risk;
left_split = 0;
}
}
me->complexity = (me->risk - (left_risk + right_risk)) /
(left_split + right_split + 1);
if (me->complexity <= ct.alpha) {
/*
* All was in vain! This node doesn't split after all.
*/
free_tree(me, 0);
*sumrisk = me->risk;
for (i = n1; i < n2; i++) {
j = ct.sorts[0][i];
if (j < 0)
j = -(1 + j);
ct.which[j] = nodenum; /* revert to the old nodenumber */
}
return 0; /* return # of splits */
} else {
*sumrisk = left_risk + right_risk;
return left_split + right_split + 1;
}
}
/*
* ja: added lossmat
*/
void classRF(double *x, int *dimx, int *cl, int *ncl, int *cat, int *maxcat,
int *sampsize, int *strata, int *Options, int *ntree, int *nvar,
int *ipi, double *classwt, double *cut, int *nodesize,
int *outcl, int *counttr, double *prox,
double *imprt, double *impsd, double *impmat, int *nrnodes,
int *ndbigtree, int *nodestatus, int *bestvar, int *treemap,
int *nodeclass, double *xbestsplit, double *errtr,
int *testdat, double *xts, int *clts, int *nts, double *countts,
int *outclts, int *labelts, double *proxts, double *errts,
int *inbag, double* lossmat) {
/******************************************************************
* C wrapper for random forests: get input from R and drive
* the Fortran routines.
*
* Input:
*
* x: matrix of predictors (transposed!)
* dimx: two integers: number of variables and number of cases
* cl: class labels of the data
* ncl: number of classes in the response
* cat: integer vector of number of classes in the predictor;
* 1=continuous
* maxcat: maximum of cat
* Options: 7 integers: (0=no, 1=yes)
* add a second class (for unsupervised RF)?
* 1: sampling from product of marginals
* 2: sampling from product of uniforms
* assess variable importance?
* calculate proximity?
* calculate proximity based on OOB predictions?
* calculate outlying measure?
* how often to print output?
* keep the forest for future prediction?
* ntree: number of trees
* nvar: number of predictors to use for each split
* ipi: 0=use class proportion as prob.; 1=use supplied priors
* pi: double vector of class priors
* nodesize: minimum node size: no node with fewer than ndsize
* cases will be split
*
* Output:
*
* outcl: class predicted by RF
* counttr: matrix of votes (transposed!)
* imprt: matrix of variable importance measures
* impmat: matrix of local variable importance measures
* prox: matrix of proximity (if iprox=1)
******************************************************************/
int nsample0, mdim, nclass, addClass, mtry, ntest, nsample, ndsize,
mimp, nimp, near, nuse, noutall, nrightall, nrightimpall,
keepInbag, nstrata;
int jb, j, n, m, k, idxByNnode, idxByNsample, imp, localImp, iprox,
oobprox, keepf, replace, stratify, trace, *nright,
*nrightimp, *nout, *nclts, Ntree;
int *out, *bestsplitnext, *bestsplit, *nodepop, *jin, *nodex,
*nodexts, *nodestart, *ta, *ncase, *jerr, *varUsed,
*jtr, *classFreq, *idmove, *jvr,
*at, *a, *b, *mind, *nind, *jts, *oobpair;
int **strata_idx, *strata_size, last, ktmp, nEmpty, ntry;
double av=0.0, delta=0.0;
double *tgini, *tx, *wl, *classpop, *tclasscat, *tclasspop, *win,
*tp, *wr, *lossmatrix;
addClass = Options[0];
imp = Options[1];
localImp = Options[2];
iprox = Options[3];
oobprox = Options[4];
trace = Options[5];
keepf = Options[6];
replace = Options[7];
stratify = Options[8];
keepInbag = Options[9];
mdim = dimx[0];
nsample0 = dimx[1];
nclass = (*ncl==1) ? 2 : *ncl;
ndsize = *nodesize;
Ntree = *ntree;
mtry = *nvar;
ntest = *nts;
nsample = addClass ? (nsample0 + nsample0) : nsample0;
mimp = imp ? mdim : 1;
nimp = imp ? nsample : 1;
near = iprox ? nsample0 : 1;
if (trace == 0) trace = Ntree + 1;
tgini = (double *) S_alloc(mdim, sizeof(double));
wl = (double *) S_alloc(nclass, sizeof(double));
wr = (double *) S_alloc(nclass, sizeof(double));
classpop = (double *) S_alloc(nclass* *nrnodes, sizeof(double)); //this gets allocated and then we pass it to Fortran
tclasscat = (double *) S_alloc(nclass*32, sizeof(double));
tclasspop = (double *) S_alloc(nclass, sizeof(double));
tx = (double *) S_alloc(nsample, sizeof(double));
win = (double *) S_alloc(nsample, sizeof(double));
tp = (double *) S_alloc(nsample, sizeof(double));
out = (int *) S_alloc(nsample, sizeof(int));
bestsplitnext = (int *) S_alloc(*nrnodes, sizeof(int));
bestsplit = (int *) S_alloc(*nrnodes, sizeof(int));
nodepop = (int *) S_alloc(*nrnodes, sizeof(int));
nodestart = (int *) S_alloc(*nrnodes, sizeof(int));
jin = (int *) S_alloc(nsample, sizeof(int));
nodex = (int *) S_alloc(nsample, sizeof(int));
nodexts = (int *) S_alloc(ntest, sizeof(int));
ta = (int *) S_alloc(nsample, sizeof(int));
ncase = (int *) S_alloc(nsample, sizeof(int));
jerr = (int *) S_alloc(nsample, sizeof(int));
varUsed = (int *) S_alloc(mdim, sizeof(int));
jtr = (int *) S_alloc(nsample, sizeof(int));
jvr = (int *) S_alloc(nsample, sizeof(int));
classFreq = (int *) S_alloc(nclass, sizeof(int));
jts = (int *) S_alloc(ntest, sizeof(int));
idmove = (int *) S_alloc(nsample, sizeof(int));
at = (int *) S_alloc(mdim*nsample, sizeof(int));
a = (int *) S_alloc(mdim*nsample, sizeof(int));
b = (int *) S_alloc(mdim*nsample, sizeof(int));
mind = (int *) S_alloc(mdim, sizeof(int));
nright = (int *) S_alloc(nclass, sizeof(int));
nrightimp = (int *) S_alloc(nclass, sizeof(int));
nout = (int *) S_alloc(nclass, sizeof(int));
if (oobprox) {
oobpair = (int *) S_alloc(near*near, sizeof(int));
}
//ja: see if we can print the lossmat
//(we can)
/*
int i;
for(i = 0; i < (nclass*nclass); i++){
Rprintf("%f\n",lossmat[i]);
}
/*
/* Count number of cases in each class. */
zeroInt(classFreq, nclass);
for (n = 0; n < nsample; ++n) classFreq[cl[n] - 1] ++;
/* Normalize class weights. */
normClassWt(cl, nsample, nclass, *ipi, classwt, classFreq);
if (stratify) {
/* Count number of strata and frequency of each stratum. */
nstrata = 0;
for (n = 0; n < nsample0; ++n)
if (strata[n] > nstrata) nstrata = strata[n];
/* Create the array of pointers, each pointing to a vector
of indices of where data of each stratum is. */
strata_size = (int *) S_alloc(nstrata, sizeof(int));
for (n = 0; n < nsample0; ++n) {
strata_size[strata[n] - 1] ++;
}
strata_idx = (int **) S_alloc(nstrata, sizeof(int *));
for (n = 0; n < nstrata; ++n) {
strata_idx[n] = (int *) S_alloc(strata_size[n], sizeof(int));
}
zeroInt(strata_size, nstrata);
for (n = 0; n < nsample0; ++n) {
strata_size[strata[n] - 1] ++;
strata_idx[strata[n] - 1][strata_size[strata[n] - 1] - 1] = n;
}
} else {
nind = replace ? NULL : (int *) S_alloc(nsample, sizeof(int));
}
/* INITIALIZE FOR RUN */
if (*testdat) zeroDouble(countts, ntest * nclass);
zeroInt(counttr, nclass * nsample);
zeroInt(out, nsample);
zeroDouble(tgini, mdim);
zeroDouble(errtr, (nclass + 1) * Ntree);
if (*labelts) {
nclts = (int *) S_alloc(nclass, sizeof(int));
for (n = 0; n < ntest; ++n) nclts[clts[n]-1]++;
zeroDouble(errts, (nclass + 1) * Ntree);
}
if (imp) {
zeroDouble(imprt, (nclass+2) * mdim);
zeroDouble(impsd, (nclass+1) * mdim);
if (localImp) zeroDouble(impmat, nsample * mdim);
}
if (iprox) {
zeroDouble(prox, nsample0 * nsample0);
if (*testdat) zeroDouble(proxts, ntest * (ntest + nsample0));
}
makeA(x, mdim, nsample, cat, at, b);
R_CheckUserInterrupt();
/* Starting the main loop over number of trees. */
GetRNGstate();
if (trace <= Ntree) {
/* Print header for running output. */
Rprintf("ntree OOB");
for (n = 1; n <= nclass; ++n) Rprintf("%7i", n);
if (*labelts) {
Rprintf("| Test");
for (n = 1; n <= nclass; ++n) Rprintf("%7i", n);
}
Rprintf("\n");
}
idxByNnode = 0;
idxByNsample = 0;
for (jb = 0; jb < Ntree; jb++) {
/* Do we need to simulate data for the second class? */
if (addClass) createClass(x, nsample0, nsample, mdim);
do {
zeroInt(nodestatus + idxByNnode, *nrnodes);
zeroInt(treemap + 2*idxByNnode, 2 * *nrnodes);
zeroDouble(xbestsplit + idxByNnode, *nrnodes);
zeroInt(nodeclass + idxByNnode, *nrnodes);
zeroInt(varUsed, mdim);
/* TODO: Put all sampling code into a function. */
/* drawSample(sampsize, nsample, ); */
if (stratify) { /* stratified sampling */
zeroInt(jin, nsample);
zeroDouble(tclasspop, nclass);
zeroDouble(win, nsample);
if (replace) { /* with replacement */
for (n = 0; n < nstrata; ++n) {
for (j = 0; j < sampsize[n]; ++j) {
ktmp = (int) (unif_rand() * strata_size[n]);
k = strata_idx[n][ktmp];
tclasspop[cl[k] - 1] += classwt[cl[k] - 1];
win[k] += classwt[cl[k] - 1];
jin[k] = 1;
}
}
} else { /* stratified sampling w/o replacement */
/* re-initialize the index array */
zeroInt(strata_size, nstrata);
for (j = 0; j < nsample; ++j) {
strata_size[strata[j] - 1] ++;
strata_idx[strata[j] - 1][strata_size[strata[j] - 1] - 1] = j;
}
/* sampling without replacement */
for (n = 0; n < nstrata; ++n) {
last = strata_size[n] - 1;
for (j = 0; j < sampsize[n]; ++j) {
ktmp = (int) (unif_rand() * (last+1));
k = strata_idx[n][ktmp];
swapInt(strata_idx[n][last], strata_idx[n][ktmp]);
last--;
tclasspop[cl[k] - 1] += classwt[cl[k]-1];
win[k] += classwt[cl[k]-1];
jin[k] = 1;
}
}
}
} else { /* unstratified sampling */
ntry = 0;
do {
nEmpty = 0;
zeroInt(jin, nsample);
zeroDouble(tclasspop, nclass);
zeroDouble(win, nsample);
if (replace) {
for (n = 0; n < *sampsize; ++n) {
k = unif_rand() * nsample;
tclasspop[cl[k] - 1] += classwt[cl[k]-1]; //total #of obs in each class in the boot sample
win[k] += classwt[cl[k]-1]; //number of times each obs appears in our boot sample (wgted by class)
jin[k] = 1; //are you in or not?
}
} else {
for (n = 0; n < nsample; ++n) nind[n] = n;
last = nsample - 1; //size of bootstrap sample - 1
for (n = 0; n < *sampsize; ++n) {
ktmp = (int) (unif_rand() * (last+1)); //a random index from 1,...n
k = nind[ktmp]; //class of the random observation
swapInt(nind[ktmp], nind[last]);
last--;
tclasspop[cl[k] - 1] += classwt[cl[k]-1];
win[k] += classwt[cl[k]-1];
jin[k] = 1;
}
}
/* check if any class is missing in the sample */
for (n = 0; n < nclass; ++n) {
if (tclasspop[n] == 0.0) nEmpty++;
}
ntry++;
} while (nclass - nEmpty < 2 && ntry <= 30);
/* If there are still fewer than two classes in the data, throw an error. */
if (nclass - nEmpty < 2) error("Still have fewer than two classes in the in-bag sample after 30 attempts.");
}
/* If need to keep indices of inbag data, do that here. */
if (keepInbag) {
for (n = 0; n < nsample0; ++n) {
inbag[n + idxByNsample] = jin[n];
}
}
/* Copy the original a matrix back. */
memcpy(a, at, sizeof(int) * mdim * nsample);
modA(a, &nuse, nsample, mdim, cat, *maxcat, ncase, jin);
//ja: added lossmat to list of arguments...
F77_CALL(buildtree)(a, b, cl, cat, maxcat, &mdim, &nsample,
&nclass,
treemap + 2*idxByNnode, bestvar + idxByNnode,
bestsplit, bestsplitnext, tgini,
nodestatus + idxByNnode, nodepop,
nodestart, classpop, tclasspop, tclasscat,
ta, nrnodes, idmove, &ndsize, ncase,
&mtry, varUsed, nodeclass + idxByNnode,
ndbigtree + jb, win, wr, wl, &mdim,
&nuse, mind, lossmat);
/* if the "tree" has only the root node, start over */
} while (ndbigtree[jb] == 1);
Xtranslate(x, mdim, *nrnodes, nsample, bestvar + idxByNnode,
bestsplit, bestsplitnext, xbestsplit + idxByNnode,
nodestatus + idxByNnode, cat, ndbigtree[jb]);
/* Get test set error */
if (*testdat) {
predictClassTree(xts, ntest, mdim, treemap + 2*idxByNnode,
nodestatus + idxByNnode, xbestsplit + idxByNnode,
bestvar + idxByNnode,
nodeclass + idxByNnode, ndbigtree[jb],
cat, nclass, jts, nodexts, *maxcat);
TestSetError(countts, jts, clts, outclts, ntest, nclass, jb+1,
errts + jb*(nclass+1), *labelts, nclts, cut);
}
/* Get out-of-bag predictions and errors. */
predictClassTree(x, nsample, mdim, treemap + 2*idxByNnode,
nodestatus + idxByNnode, xbestsplit + idxByNnode,
bestvar + idxByNnode,
nodeclass + idxByNnode, ndbigtree[jb],
cat, nclass, jtr, nodex, *maxcat);
zeroInt(nout, nclass);
noutall = 0;
for (n = 0; n < nsample; ++n) {
if (jin[n] == 0) {
/* increment the OOB votes */
counttr[n*nclass + jtr[n] - 1] ++;
/* count number of times a case is OOB */
out[n]++;
/* count number of OOB cases in the current iteration.
nout[n] is the number of OOB cases for the n-th class.
noutall is the number of OOB cases overall. */
nout[cl[n] - 1]++;
noutall++;
}
}
/* Compute out-of-bag error rate. */
oob(nsample, nclass, jin, cl, jtr, jerr, counttr, out,
errtr + jb*(nclass+1), outcl, cut);
if ((jb+1) % trace == 0) {
Rprintf("%5i: %6.2f%%", jb+1, 100.0*errtr[jb * (nclass+1)]);
for (n = 1; n <= nclass; ++n) {
Rprintf("%6.2f%%", 100.0 * errtr[n + jb * (nclass+1)]);
}
if (*labelts) {
Rprintf("| ");
for (n = 0; n <= nclass; ++n) {
Rprintf("%6.2f%%", 100.0 * errts[n + jb * (nclass+1)]);
}
}
Rprintf("\n");
#ifdef WIN32
R_FlushConsole();
R_ProcessEvents();
#endif
R_CheckUserInterrupt();
}
/* DO PROXIMITIES */
if (iprox) {
computeProximity(prox, oobprox, nodex, jin, oobpair, near);
/* proximity for test data */
if (*testdat) {
computeProximity(proxts, 0, nodexts, jin, oobpair, ntest);
/* Compute proximity between testset and training set. */
for (n = 0; n < ntest; ++n) {
for (k = 0; k < near; ++k) {
if (nodexts[n] == nodex[k])
proxts[n + ntest * (k+ntest)] += 1.0;
}
}
}
}
/* DO VARIABLE IMPORTANCE */
if (imp) {
nrightall = 0;
/* Count the number of correct prediction by the current tree
among the OOB samples, by class. */
zeroInt(nright, nclass);
for (n = 0; n < nsample; ++n) {
/* out-of-bag and predicted correctly: */
if (jin[n] == 0 && jtr[n] == cl[n]) {
nright[cl[n] - 1]++;
nrightall++;
}
}
for (m = 0; m < mdim; ++m) {
if (varUsed[m]) {
nrightimpall = 0;
zeroInt(nrightimp, nclass);
for (n = 0; n < nsample; ++n) tx[n] = x[m + n*mdim];
/* Permute the m-th variable. */
permuteOOB(m, x, jin, nsample, mdim);
/* Predict the modified data using the current tree. */
predictClassTree(x, nsample, mdim, treemap + 2*idxByNnode,
nodestatus + idxByNnode,
xbestsplit + idxByNnode,
bestvar + idxByNnode,
nodeclass + idxByNnode, ndbigtree[jb],
cat, nclass, jvr, nodex, *maxcat);
/* Count how often correct predictions are made with
the modified data. */
for (n = 0; n < nsample; n++) {
/* Restore the original data for that variable. */
x[m + n*mdim] = tx[n];
if (jin[n] == 0) {
if (jvr[n] == cl[n]) {
+ nrightimp[cl[n] - 1]++;
nrightimpall++;
}
if (localImp && jvr[n] != jtr[n]) {
if (cl[n] == jvr[n]) {
impmat[m + n*mdim] -= 1.0;
} else {
impmat[m + n*mdim] += 1.0;
}
}
}
}
/* Accumulate decrease in proportions of correct
predictions. */
/* class-specific measures first: */
for (n = 0; n < nclass; ++n) {
if (nout[n] > 0) {
delta = ((double) (nright[n] - nrightimp[n])) / nout[n];
imprt[m + n*mdim] += delta;
impsd[m + n*mdim] += delta * delta;
}
}
/* overall measure, across all classes: */
if (noutall > 0) {
delta = ((double)(nrightall - nrightimpall)) / noutall;
imprt[m + nclass*mdim] += delta;
impsd[m + nclass*mdim] += delta * delta;
}
}
}
}
R_CheckUserInterrupt();
#ifdef WIN32
R_ProcessEvents();
#endif
if (keepf) idxByNnode += *nrnodes;
if (keepInbag) idxByNsample += nsample0;
}
PutRNGstate();
/* Final processing of variable importance. */
for (m = 0; m < mdim; m++) tgini[m] /= Ntree;
if (imp) {
for (m = 0; m < mdim; ++m) {
if (localImp) { /* casewise measures */
for (n = 0; n < nsample; ++n) impmat[m + n*mdim] /= out[n];
}
/* class-specific measures */
for (k = 0; k < nclass; ++k) {
av = imprt[m + k*mdim] / Ntree;
impsd[m + k*mdim] =
sqrt(((impsd[m + k*mdim] / Ntree) - av*av) / Ntree);
imprt[m + k*mdim] = av;
/* imprt[m + k*mdim] = (se <= 0.0) ? -1000.0 - av : av / se; */
}
/* overall measures */
av = imprt[m + nclass*mdim] / Ntree;
impsd[m + nclass*mdim] =
sqrt(((impsd[m + nclass*mdim] / Ntree) - av*av) / Ntree);
imprt[m + nclass*mdim] = av;
imprt[m + (nclass+1)*mdim] = tgini[m];
}
} else {
for (m = 0; m < mdim; ++m) imprt[m] = tgini[m];
}
/* PROXIMITY DATA ++++++++++++++++++++++++++++++++*/
if (iprox) {
for (n = 0; n < near; ++n) {
for (k = n + 1; k < near; ++k) {
prox[near*k + n] /= oobprox ?
(oobpair[near*k + n] > 0 ? oobpair[near*k + n] : 1) :
Ntree;
prox[near*n + k] = prox[near*k + n];
}
prox[near*n + n] = 1.0;
}
if (*testdat) {
for (n = 0; n < ntest; ++n) {
for (k = 0; k < ntest + nsample; ++k)
proxts[ntest*k + n] /= Ntree;
proxts[ntest * n + n] = 1.0;
}
}
}
}
void hSDM_ZIB (
// Constants and data
const int *ngibbs, int *nthin, int *nburn, // Number of iterations, burning and samples
const int *nobs, // Number of observations
const int *np, // Number of fixed effects for prob_p
const int *nq, // Number of fixed effects for prob_q
const int *Y_vect, // Number of successes (presences)
const int *T_vect, // Number of trials
const double *X_vect, // Suitability covariates
const double *W_vect, // Observability covariates
// Predictions
const int *npred, // Number of predictions
const double *X_pred_vect, // Suitability covariates for predictions
// Starting values for M-H
const double *beta_start,
const double *gamma_start,
// Parameters to save
double *beta_vect,
double *gamma_vect,
// Defining priors
const double *mubeta, double *Vbeta,
const double *mugamma, double *Vgamma,
// Diagnostic
double *Deviance,
double *prob_p_latent, // Latent proba of suitability (length NOBS)
double *prob_q_latent, // Latent proba of observability (length NOBS)
double *prob_p_pred, // Proba of suitability for predictions (length NPRED)
// Seeds
const int *seed,
// Verbose
const int *verbose,
// Save p
const int *save_p
) {
////////////////////////////////////////////////////////////////////////////////
//%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
// Defining and initializing objects
////////////////////////////////////////
// Initialize random number generator //
srand(seed[0]);
///////////////////////////
// Redefining constants //
const int NGIBBS=ngibbs[0];
const int NTHIN=nthin[0];
const int NBURN=nburn[0];
const int NSAMP=(NGIBBS-NBURN)/NTHIN;
const int NOBS=nobs[0];
const int NP=np[0];
const int NQ=nq[0];
const int NPRED=npred[0];
///////////////////////////////////
// Declaring some useful objects //
double *prob_p_run=malloc(NOBS*sizeof(double));
for (int n=0; n<NOBS; n++) {
prob_p_run[n]=0.0;
}
double *prob_q_run=malloc(NOBS*sizeof(double));
for (int n=0; n<NOBS; n++) {
prob_q_run[n]=0.0;
}
double *prob_p_pred_run=malloc(NPRED*sizeof(double));
for (int m=0; m<NPRED; m++) {
prob_p_pred_run[m]=0.0;
}
//////////////////////////////////////////////////////////
// Set up and initialize structure for density function //
struct dens_par dens_data;
/* Data */
dens_data.NOBS=NOBS;
// Y
dens_data.Y=malloc(NOBS*sizeof(int));
for (int n=0; n<NOBS; n++) {
dens_data.Y[n]=Y_vect[n];
}
// T
dens_data.T=malloc(NOBS*sizeof(int));
for (int n=0; n<NOBS; n++) {
dens_data.T[n]=T_vect[n];
}
/* Suitability process */
dens_data.NP=NP;
dens_data.pos_beta=0;
dens_data.X=malloc(NOBS*sizeof(double*));
for (int n=0; n<NOBS; n++) {
dens_data.X[n]=malloc(NP*sizeof(double));
for (int p=0; p<NP; p++) {
dens_data.X[n][p]=X_vect[p*NOBS+n];
}
}
dens_data.mubeta=malloc(NP*sizeof(double));
dens_data.Vbeta=malloc(NP*sizeof(double));
for (int p=0; p<NP; p++) {
dens_data.mubeta[p]=mubeta[p];
dens_data.Vbeta[p]=Vbeta[p];
}
dens_data.beta_run=malloc(NP*sizeof(double));
for (int p=0; p<NP; p++) {
dens_data.beta_run[p]=beta_start[p];
}
/* Observability process */
dens_data.NQ=NQ;
dens_data.pos_gamma=0;
dens_data.W=malloc(NOBS*sizeof(double*));
for (int n=0; n<NOBS; n++) {
dens_data.W[n]=malloc(NQ*sizeof(double));
for (int q=0; q<NQ; q++) {
dens_data.W[n][q]=W_vect[q*NOBS+n];
}
}
dens_data.mugamma=malloc(NQ*sizeof(double));
dens_data.Vgamma=malloc(NQ*sizeof(double));
for (int q=0; q<NQ; q++) {
dens_data.mugamma[q]=mugamma[q];
dens_data.Vgamma[q]=Vgamma[q];
}
dens_data.gamma_run=malloc(NQ*sizeof(double));
for (int q=0; q<NQ; q++) {
dens_data.gamma_run[q]=gamma_start[q];
}
/* Predictions */
// X_pred
double **X_pred=malloc(NPRED*sizeof(double*));
for (int m=0; m<NPRED; m++) {
X_pred[m]=malloc(NP*sizeof(double));
for (int p=0; p<NP; p++) {
X_pred[m][p]=X_pred_vect[p*NPRED+m];
}
}
////////////////////////////////////////////////////////////
// Proposal variance and acceptance for adaptive sampling //
// beta
double *sigmap_beta = malloc(NP*sizeof(double));
int *nA_beta = malloc(NP*sizeof(int));
double *Ar_beta = malloc(NP*sizeof(double)); // Acceptance rate
for (int p=0; p<NP; p++) {
nA_beta[p]=0;
sigmap_beta[p]=1.0;
Ar_beta[p]=0.0;
}
// gamma
double *sigmap_gamma = malloc(NQ*sizeof(double));
int *nA_gamma = malloc(NQ*sizeof(int));
double *Ar_gamma = malloc(NQ*sizeof(double)); // Acceptance rate
for (int q=0; q<NQ; q++) {
nA_gamma[q]=0;
sigmap_gamma[q]=1.0;
Ar_gamma[q]=0.0;
}
////////////
// Message//
Rprintf("\nRunning the Gibbs sampler. It may be long, please keep cool :)\n\n");
R_FlushConsole();
//R_ProcessEvents(); for windows
///////////////////////////////////////////////////////////////////////////////////////
//%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
// Gibbs sampler
for (int g=0; g<NGIBBS; g++) {
////////////////////////////////////////////////
// beta
for (int p=0; p<NP; p++) {
dens_data.pos_beta=p; // Specifying the rank of the parameter of interest
double x_now=dens_data.beta_run[p];
double x_prop=myrnorm(x_now,sigmap_beta[p]);
double p_now=betadens(x_now, &dens_data);
double p_prop=betadens(x_prop, &dens_data);
double r=exp(p_prop-p_now); // ratio
double z=myrunif();
// Actualization
if (z < r) {
dens_data.beta_run[p]=x_prop;
nA_beta[p]++;
}
}
////////////////////////////////////////////////
// gamma
for (int q=0; q<NQ; q++) {
dens_data.pos_gamma=q; // Specifying the rank of the parameter of interest
double x_now=dens_data.gamma_run[q];
double x_prop=myrnorm(x_now,sigmap_gamma[q]);
double p_now=gammadens(x_now, &dens_data);
double p_prop=gammadens(x_prop, &dens_data);
double r=exp(p_prop-p_now); // ratio
double z=myrunif();
// Actualization
if (z < r) {
dens_data.gamma_run[q]=x_prop;
nA_gamma[q]++;
}
}
//////////////////////////////////////////////////
// Deviance
// logLikelihood
double logL=0.0;
for (int n=0; n<NOBS; n++) {
/* prob_p */
double Xpart_prob_p=0.0;
for (int p=0; p<NP; p++) {
Xpart_prob_p+=dens_data.X[n][p]*dens_data.beta_run[p];
}
prob_p_run[n]=invlogit(Xpart_prob_p);
/* prob_q */
double logit_prob_q=0.0;
for (int q=0; q<NQ; q++) {
logit_prob_q+=dens_data.W[n][q]*dens_data.gamma_run[q];
}
prob_q_run[n]=invlogit(logit_prob_q);
/* log Likelihood */
if (dens_data.Y[n]>0) {
logL+=dbinom(dens_data.Y[n],dens_data.T[n],prob_q_run[n],1)+log(prob_p_run[n]);
}
if (dens_data.Y[n]==0) {
logL+=log(pow(1-prob_q_run[n],dens_data.T[n])*prob_p_run[n]+(1-prob_p_run[n]));
}
}
// Deviance
double Deviance_run=-2*logL;
//////////////////////////////////////////////////
// Predictions
for (int m=0; m<NPRED; m++) {
/* prob_p_pred_run */
double Xpart_prob_p_pred=0.0;
for (int p=0; p<NP; p++) {
Xpart_prob_p_pred+=X_pred[m][p]*dens_data.beta_run[p];
}
prob_p_pred_run[m]=invlogit(Xpart_prob_p_pred);
}
//////////////////////////////////////////////////
// Output
if (((g+1)>NBURN) && (((g+1)%(NTHIN))==0)) {
int isamp=((g+1)-NBURN)/(NTHIN);
for (int p=0; p<NP; p++) {
beta_vect[p*NSAMP+(isamp-1)]=dens_data.beta_run[p];
}
for (int q=0; q<NQ; q++) {
gamma_vect[q*NSAMP+(isamp-1)]=dens_data.gamma_run[q];
}
Deviance[isamp-1]=Deviance_run;
for (int n=0; n<NOBS; n++) {
prob_p_latent[n]+=prob_p_run[n]/NSAMP; // We compute the mean of NSAMP values
prob_q_latent[n]+=prob_q_run[n]/NSAMP; // We compute the mean of NSAMP values
}
// prob.p
if (save_p[0]==0) { // We compute the mean of NSAMP values
for (int m=0; m<NPRED; m++) {
prob_p_pred[m]+=prob_p_pred_run[m]/NSAMP;
}
}
if (save_p[0]==1) { // The NSAMP sampled values for prob_p are saved
for (int m=0; m<NPRED; m++) {
prob_p_pred[m*NSAMP+(isamp-1)]=prob_p_pred_run[m];
}
}
}
///////////////////////////////////////////////////////
// Adaptive sampling (on the burnin period)
const double ropt=0.234;
int DIV=0;
if (NGIBBS >=1000) DIV=100;
else DIV=NGIBBS/10;
/* During the burnin period */
if ((g+1)%DIV==0 && (g+1)<=NBURN) {
// beta
for (int p=0; p<NP; p++) {
Ar_beta[p]=((double) nA_beta[p])/DIV;
if (Ar_beta[p]>=ropt) sigmap_beta[p]=sigmap_beta[p]*(2-(1-Ar_beta[p])/(1-ropt));
else sigmap_beta[p]=sigmap_beta[p]/(2-Ar_beta[p]/ropt);
nA_beta[p]=0.0; // We reinitialize the number of acceptance to zero
}
// gamma
for (int q=0; q<NQ; q++) {
Ar_gamma[q]=((double) nA_gamma[q])/DIV;
if (Ar_gamma[q]>=ropt) sigmap_gamma[q]=sigmap_gamma[q]*(2-(1-Ar_gamma[q])/(1-ropt));
else sigmap_gamma[q]=sigmap_gamma[q]/(2-Ar_gamma[q]/ropt);
nA_gamma[q]=0.0; // We reinitialize the number of acceptance to zero
}
}
/* After the burnin period */
if ((g+1)%DIV==0 && (g+1)>NBURN) {
// beta
for (int p=0; p<NP; p++) {
Ar_beta[p]=((double) nA_beta[p])/DIV;
nA_beta[p]=0.0; // We reinitialize the number of acceptance to zero
}
// gamma
for (int q=0; q<NQ; q++) {
Ar_gamma[q]=((double) nA_gamma[q])/DIV;
nA_gamma[q]=0.0; // We reinitialize the number of acceptance to zero
}
}
//////////////////////////////////////////////////
// Progress bar
double Perc=100*(g+1)/(NGIBBS);
if (((g+1)%(NGIBBS/100))==0 && verbose[0]==1) {
Rprintf("*");
R_FlushConsole();
//R_ProcessEvents(); for windows
if (((g+1)%(NGIBBS/10))==0) {
double mAr_beta=0; // Mean acceptance rate
double mAr_gamma=0;
// beta
for (int p=0; p<NP; p++) {
mAr_beta+=Ar_beta[p]/NP;
}
// gamma
for (int q=0; q<NQ; q++) {
mAr_gamma+=Ar_gamma[q]/NQ;
}
Rprintf(":%.1f%%, mean accept. rates= beta:%.3f, gamma:%.3f\n",Perc,mAr_beta,mAr_gamma);
R_FlushConsole();
//R_ProcessEvents(); for windows
}
}
//////////////////////////////////////////////////
// User interrupt
R_CheckUserInterrupt(); // allow user interrupt
} // Gibbs sampler
///////////////
// Delete memory allocation (see malloc())
/* Data */
free(dens_data.Y);
free(dens_data.T);
/* Suitability */
for (int n=0; n<NOBS; n++) {
free(dens_data.X[n]);
}
free(dens_data.X);
free(dens_data.mubeta);
free(dens_data.Vbeta);
free(dens_data.beta_run);
free(prob_p_run);
/* Observability */
for (int n=0; n<NOBS; n++) {
free(dens_data.W[n]);
}
free(dens_data.W);
free(dens_data.mugamma);
free(dens_data.Vgamma);
free(dens_data.gamma_run);
free(prob_q_run);
/* Predictions */
for (int m=0; m<NPRED; m++) {
free(X_pred[m]);
}
free(X_pred);
free(prob_p_pred_run);
/* Adaptive MH */
free(sigmap_beta);
free(nA_beta);
free(Ar_beta);
free(sigmap_gamma);
free(nA_gamma);
free(Ar_gamma);
} // end hSDM function
void BweibDpCorSurvmcmc(double survData[],
int *n,
int *p,
int *J,
double nj[],
double hyperParams[],
double mcmcParams[],
double startValues[],
int *numReps,
int *thin,
double *burninPerc,
double samples_beta[],
double samples_alpha[],
double samples_kappa[],
double samples_V[],
double samples_c[],
double samples_mu[],
double samples_zeta[],
double samples_tau[],
double samples_misc[],
double moveVec[])
{
GetRNGstate();
time_t now;
int i, j, MM;
const gsl_rng_type * TT;
gsl_rng * rr;
gsl_rng_env_setup();
TT = gsl_rng_default;
rr = gsl_rng_alloc(TT);
/* Survival Data */
gsl_vector *survTime = gsl_vector_alloc(*n);
gsl_vector *survEvent = gsl_vector_alloc(*n);
gsl_vector *cluster = gsl_vector_alloc(*n);
for(i = 0; i < *n; i++)
{
gsl_vector_set(survTime, i, survData[(0 * *n) + i]);
gsl_vector_set(survEvent, i, survData[(1* *n) + i]);
gsl_vector_set(cluster, i, survData[(2* *n) + i]);
}
int nP;
if(*p > 0) nP = *p;
if(*p == 0) nP = 1;
gsl_matrix *survCov = gsl_matrix_calloc(*n, nP);
if(*p >0)
{
for(i = 0; i < *n; i++)
{
for(j = 0; j < *(p); j++)
{
gsl_matrix_set(survCov, i, j, survData[((3+j)* *n) + i]);
}
}
}
gsl_vector *n_j = gsl_vector_calloc(*J);
for(j = 0; j < *J; j++)
{
gsl_vector_set(n_j, j, nj[j]);
}
/* Hyperparameters */
double a = hyperParams[0];
double b = hyperParams[1];
double c_kappa = hyperParams[2];
double d = hyperParams[3];
double mu0 = hyperParams[4];
double zeta0 = hyperParams[5];
double a0 = hyperParams[6];
double b0 = hyperParams[7];
double aTau = hyperParams[8];
double bTau = hyperParams[9];
/* varialbes for M-H step */
double mhProp_alpha_var = mcmcParams[0];
double mhProp_V_var = mcmcParams[1];
/* Starting values */
gsl_vector *beta = gsl_vector_calloc(nP);
if(*p > 0)
{
for(j = 0; j < *p; j++) gsl_vector_set(beta, j, startValues[j]);
}
double alpha = startValues[*p];
double kappa = startValues[*p + 1];
gsl_vector *V = gsl_vector_calloc(*J);
for(j = 0; j < *J; j++)
{
gsl_vector_set(V, j, startValues[*p + 2 + j]);
}
gsl_vector *c = gsl_vector_calloc(*J);
for(i = 0; i < *J; i++)
{
gsl_vector_set(c, i, startValues[*p + 2 + *J + i]);
}
double tau = startValues[*p + 2 + *J + *J];
/* Variables required for storage of samples */
int StoreInx;
gsl_vector *accept_beta = gsl_vector_calloc(nP);
gsl_vector *accept_V = gsl_vector_calloc(*J);
int accept_alpha = 0;
gsl_vector *mu_all = gsl_vector_calloc(*J);
gsl_vector *zeta_all = gsl_vector_calloc(*J);
int nClass_DP;
/* Compute probabilities for various types of moves */
double pRP, pSH, pSC, pCP, choice;
int move, numUpdate;
numUpdate = 3;
if(*p > 0) numUpdate += 1;
/* */
pCP = (double) 0.3;
double probSub = (1 - pCP)/(numUpdate-1);
pRP = (*p > 0) ? probSub : 0;
pSC = probSub;
pSH = 1-(pRP + pSC + pCP);
for(MM = 0; MM < *numReps; MM++)
{
/* selecting a move */
/* move: 1=RP, 2=SH, 3=SC, 4=CP */
choice = runif(0, 1);
move = 1;
if(choice > pRP) move = 2;
if(choice > pRP + pSH) move = 3;
if(choice > pRP + pSH + pSC) move = 4;
moveVec[MM] = (double) move;
/* updating regression parameter: beta */
if(move == 1)
{
BweibDpCorSurv_updateRP(beta, &alpha, &kappa, V, survTime, survEvent, cluster, survCov, accept_beta);
}
/* updating shape parameter: alpha */
if(move == 2)
{
BweibDpCorSurv_updateSH_rw2(beta, &alpha, &kappa, V, survTime, survEvent, cluster, survCov, mhProp_alpha_var, a, b, &accept_alpha);
}
/* updating scale parameter: kappa */
if(move == 3)
{
BweibDpCorSurv_updateSC(beta, &alpha, &kappa, V, survTime, survEvent, cluster, survCov, c_kappa, d);
}
/* updating cluster-specific random effect: V */
if(move == 4)
{
BweibDpCorSurv_updateCP(beta, alpha, kappa, V, survTime, survEvent, cluster, survCov, n_j, mu_all, zeta_all, c, accept_V, mhProp_V_var, mu0, zeta0, a0, b0, tau, &nClass_DP, rr);
BweibDpCorSurv_updatePP(J, &tau, aTau, bTau, &nClass_DP);
}
/* */
/* Storing posterior samples */
if( ( (MM+1) % *thin ) == 0 && (MM+1) > (*numReps * *burninPerc))
{
StoreInx = (MM+1)/(*thin)- (*numReps * *burninPerc)/(*thin);
samples_alpha[StoreInx - 1] = alpha;
samples_kappa[StoreInx - 1] = kappa;
if(*p >0)
{
for(j = 0; j < *p; j++) samples_beta[(StoreInx - 1) * (*p) + j] = gsl_vector_get(beta, j);
}
for(j = 0; j < *J; j++) samples_V[(StoreInx - 1) * (*J) + j] = gsl_vector_get(V, j);
for(j = 0; j < *J; j++) samples_c[(StoreInx - 1) * (*J) + j] = gsl_vector_get(c, j);
for(j = 0; j < *J; j++) samples_mu[(StoreInx - 1) * (*J) + j] = gsl_vector_get(mu_all, j);
for(j = 0; j < *J; j++) samples_zeta[(StoreInx - 1) * (*J) + j] = gsl_vector_get(zeta_all, j);
samples_tau[StoreInx - 1] = tau;
if(MM == (*numReps - 1))
{
/* */
if(*p >0)
{
for(j = 0; j < *p; j++) samples_misc[j] = (int) gsl_vector_get(accept_beta, j);
}
/* */
samples_misc[*p] = accept_alpha;
/* */
for(i = 0; i < *J; i++) samples_misc[*p + 1 + i] = (int) gsl_vector_get(accept_V, i);
}
}
if( ( (MM+1) % 10000 ) == 0)
{
time(&now);
Rprintf("iteration: %d: %s\n", MM+1, ctime(&now));
R_FlushConsole();
R_ProcessEvents();
}
}
PutRNGstate();
return;
}
SEXP attribute_hidden
do_getGraphicsEvent(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP result = R_NilValue, prompt;
pDevDesc dd;
pGEDevDesc gd;
int i, count=0, devNum;
checkArity(op, args);
prompt = CAR(args);
if (!isString(prompt) || !length(prompt)) error(_("invalid prompt"));
/* NB: cleanup of event handlers must be done by driver in onExit handler */
if (!NoDevices()) {
/* Initialize all devices */
i = 1;
devNum = curDevice();
while (i++ < NumDevices()) {
gd = GEgetDevice(devNum);
dd = gd->dev;
if (dd->gettingEvent)
error(_("recursive use of getGraphicsEvent not supported"));
if (dd->eventEnv != R_NilValue) {
if (dd->eventHelper) dd->eventHelper(dd, 1);
dd->gettingEvent = TRUE;
defineVar(install("result"), R_NilValue, dd->eventEnv);
count++;
}
devNum = nextDevice(devNum);
}
if (!count)
error(_("no graphics event handlers set"));
Rprintf("%s\n", CHAR(asChar(prompt)));
R_FlushConsole();
/* Poll them */
while (result == R_NilValue) {
R_ProcessEvents();
R_CheckUserInterrupt();
i = 1;
devNum = curDevice();
while (i++ < NumDevices()) {
gd = GEgetDevice(devNum);
dd = gd->dev;
if (dd->eventEnv != R_NilValue) {
if (dd->eventHelper) dd->eventHelper(dd, 2);
result = findVar(install("result"), dd->eventEnv);
if (result != R_NilValue && result != R_UnboundValue) {
break;
}
}
devNum = nextDevice(devNum);
}
}
/* clean up */
i = 1;
devNum = curDevice();
while (i++ < NumDevices()) {
gd = GEgetDevice(devNum);
dd = gd->dev;
if (dd->eventEnv != R_NilValue) {
if (dd->eventHelper) dd->eventHelper(dd, 0);
dd->gettingEvent = FALSE;
}
devNum = nextDevice(devNum);
}
}
return(result);
}
void MARprobit(int *Y, /* binary outcome variable */
int *Ymiss, /* missingness indicator for Y */
int *iYmax, /* maximum value of Y; 0,1,...,Ymax */
int *Z, /* treatment assignment */
int *D, /* treatment status */
int *C, /* compliance status */
double *dX, double *dXo, /* covariates */
double *dBeta, double *dGamma, /* coefficients */
int *iNsamp, int *iNgen, int *iNcov, int *iNcovo,
int *iNcovoX, int *iN11,
/* counters */
double *beta0, double *gamma0, double *dA, double *dAo, /*prior */
int *insample, /* 1: insample inference, 2: conditional inference */
int *smooth,
int *param, int *mda, int *iBurnin,
int *iKeep, int *verbose, /* options */
double *pdStore
) {
/*** counters ***/
int n_samp = *iNsamp; /* sample size */
int n_gen = *iNgen; /* number of gibbs draws */
int n_cov = *iNcov; /* number of covariates */
int n_covo = *iNcovo; /* number of all covariates for outcome model */
int n_covoX = *iNcovoX; /* number of covariates excluding smooth
terms */
int n11 = *iN11; /* number of compliers in the treament group */
/*** data ***/
double **X; /* covariates for the compliance model */
double **Xo; /* covariates for the outcome model */
double *W; /* latent variable */
int Ymax = *iYmax;
/*** model parameters ***/
double *beta; /* coef for compliance model */
double *gamma; /* coef for outcomme model */
double *q; /* some parameters for sampling C */
double *pc;
double *pn;
double pcmean;
double pnmean;
double **SS; /* matrix folders for SWEEP */
double **SSo;
// HJ commented it out on April 17, 2018
// double **SSr;
double *meanb; /* means for beta and gamma */
double *meano;
double *meanr;
double **V; /* variances for beta and gamma */
double **Vo;
double **Vr;
double **A;
double **Ao;
double *tau; /* thresholds: tau_0, ..., tau_{Ymax-1} */
double *taumax; /* corresponding max and min for tau */
double *taumin; /* tau_0 is fixed to 0 */
double *treat; /* smooth function for treat */
/*** quantities of interest ***/
int n_comp, n_compC, n_ncompC;
double *ITTc;
double *base;
/*** storage parameters and loop counters **/
int progress = 1;
int keep = 1;
int i, j, k, main_loop;
int itemp, itempP = ftrunc((double) n_gen/10);
double dtemp, ndraw, cdraw;
double *vtemp;
double **mtemp, **mtempo;
/*** marginal data augmentation ***/
double sig2 = 1;
int nu0 = 1;
double s0 = 1;
/*** get random seed **/
GetRNGstate();
/*** define vectors and matricies **/
X = doubleMatrix(n_samp+n_cov, n_cov+1);
Xo = doubleMatrix(n_samp+n_covo, n_covo+1);
W = doubleArray(n_samp);
tau = doubleArray(Ymax);
taumax = doubleArray(Ymax);
taumin = doubleArray(Ymax);
SS = doubleMatrix(n_cov+1, n_cov+1);
SSo = doubleMatrix(n_covo+1, n_covo+1);
// HJ commented it out on April 17, 2018
// SSr = doubleMatrix(4, 4);
V = doubleMatrix(n_cov, n_cov);
Vo = doubleMatrix(n_covo, n_covo);
Vr = doubleMatrix(3, 3);
beta = doubleArray(n_cov);
gamma = doubleArray(n_covo);
meanb = doubleArray(n_cov);
meano = doubleArray(n_covo);
meanr = doubleArray(3);
q = doubleArray(n_samp);
pc = doubleArray(n_samp);
pn = doubleArray(n_samp);
A = doubleMatrix(n_cov, n_cov);
Ao = doubleMatrix(n_covo, n_covo);
vtemp = doubleArray(n_samp);
mtemp = doubleMatrix(n_cov, n_cov);
mtempo = doubleMatrix(n_covo, n_covo);
ITTc = doubleArray(Ymax+1);
treat = doubleArray(n11);
base = doubleArray(2);
/*** read the data ***/
itemp = 0;
for (j =0; j < n_cov; j++)
for (i = 0; i < n_samp; i++)
X[i][j] = dX[itemp++];
itemp = 0;
for (j =0; j < n_covo; j++)
for (i = 0; i < n_samp; i++)
Xo[i][j] = dXo[itemp++];
/*** read the prior and it as additional data points ***/
itemp = 0;
for (k = 0; k < n_cov; k++)
for (j = 0; j < n_cov; j++)
A[j][k] = dA[itemp++];
itemp = 0;
for (k = 0; k < n_covo; k++)
for (j = 0; j < n_covo; j++)
Ao[j][k] = dAo[itemp++];
dcholdc(A, n_cov, mtemp);
for(i = 0; i < n_cov; i++) {
X[n_samp+i][n_cov]=0;
for(j = 0; j < n_cov; j++) {
X[n_samp+i][n_cov] += mtemp[i][j]*beta0[j];
X[n_samp+i][j] = mtemp[i][j];
}
}
dcholdc(Ao, n_covo, mtempo);
for(i = 0; i < n_covo; i++) {
Xo[n_samp+i][n_covo]=0;
for(j = 0; j < n_covo; j++) {
Xo[n_samp+i][n_covo] += mtempo[i][j]*gamma0[j];
Xo[n_samp+i][j] = mtempo[i][j];
}
}
/*** starting values ***/
for (i = 0; i < n_cov; i++)
beta[i] = dBeta[i];
for (i = 0; i < n_covo; i++)
gamma[i] = dGamma[i];
if (Ymax > 1) {
tau[0] = 0.0;
taumax[0] = 0.0;
taumin[0] = 0.0;
for (i = 1; i < Ymax; i++)
tau[i] = tau[i-1]+2/(double)(Ymax-1);
}
for (i = 0; i < n_samp; i++) {
pc[i] = unif_rand();
pn[i] = unif_rand();
}
/*** Gibbs Sampler! ***/
itemp=0;
for(main_loop = 1; main_loop <= n_gen; main_loop++){
/** COMPLIANCE MODEL **/
if (*mda) sig2 = s0/rchisq((double)nu0);
/* Draw complier status for control group */
for(i = 0; i < n_samp; i++){
dtemp = 0;
for(j = 0; j < n_cov; j++)
dtemp += X[i][j]*beta[j];
if(Z[i] == 0){
q[i] = pnorm(dtemp, 0, 1, 1, 0);
if(unif_rand() < (q[i]*pc[i]/(q[i]*pc[i]+(1-q[i])*pn[i]))) {
C[i] = 1; Xo[i][1] = 1;
}
else {
C[i] = 0; Xo[i][1] = 0;
}
}
/* Sample W */
if(C[i]==0)
W[i] = TruncNorm(dtemp-100,0,dtemp,1,0);
else
W[i] = TruncNorm(0,dtemp+100,dtemp,1,0);
X[i][n_cov] = W[i]*sqrt(sig2);
W[i] *= sqrt(sig2);
}
/* SS matrix */
for(j = 0; j <= n_cov; j++)
for(k = 0; k <= n_cov; k++)
SS[j][k]=0;
for(i = 0; i < n_samp+n_cov; i++)
for(j = 0; j <= n_cov; j++)
for(k = 0; k <= n_cov; k++)
SS[j][k] += X[i][j]*X[i][k];
/* SWEEP SS matrix */
for(j = 0; j < n_cov; j++)
SWP(SS, j, n_cov+1);
/* draw beta */
for(j = 0; j < n_cov; j++)
meanb[j] = SS[j][n_cov];
if (*mda)
sig2=(SS[n_cov][n_cov]+s0)/rchisq((double)n_samp+nu0);
for(j = 0; j < n_cov; j++)
for(k = 0; k < n_cov; k++) V[j][k] = -SS[j][k]*sig2;
rMVN(beta, meanb, V, n_cov);
/* rescale the parameters */
if(*mda) {
for (i = 0; i < n_cov; i++) beta[i] /= sqrt(sig2);
}
/** OUTCOME MODEL **/
/* Sample W */
if (Ymax > 1) { /* tau_0=0, tau_1, ... */
for (j = 1; j < (Ymax - 1); j++) {
taumax[j] = tau[j+1];
taumin[j] = tau[j-1];
}
taumax[Ymax-1] = tau[Ymax-1]+100;
taumin[Ymax-1] = tau[Ymax-2];
}
if (*mda) sig2 = s0/rchisq((double)nu0);
for (i = 0; i < n_samp; i++){
dtemp = 0;
for (j = 0; j < n_covo; j++) dtemp += Xo[i][j]*gamma[j];
if (Ymiss[i] == 1) {
W[i] = dtemp + norm_rand();
if (Ymax == 1) { /* binary probit */
if (W[i] > 0) Y[i] = 1;
else Y[i] = 0;
}
else { /* ordered probit */
if (W[i] >= tau[Ymax-1])
Y[i] = Ymax;
else {
j = 0;
while (W[i] > tau[j] && j < Ymax) j++;
Y[i] = j;
}
}
}
else {
if(Ymax == 1) { /* binary probit */
if(Y[i] == 0) W[i] = TruncNorm(dtemp-100,0,dtemp,1,0);
else W[i] = TruncNorm(0,dtemp+100,dtemp,1,0);
}
else { /* ordered probit */
if (Y[i] == 0)
W[i] = TruncNorm(dtemp-100, 0, dtemp, 1, 0);
else if (Y[i] == Ymax) {
W[i] = TruncNorm(tau[Ymax-1], dtemp+100, dtemp, 1, 0);
if (W[i] < taumax[Ymax-1]) taumax[Ymax-1] = W[i];
}
else {
W[i] = TruncNorm(tau[Y[i]-1], tau[Y[i]], dtemp, 1, 0);
if (W[i] > taumin[Y[i]]) taumin[Y[i]] = W[i];
if (W[i] < taumax[Y[i]-1]) taumax[Y[i]-1] = W[i];
}
}
}
Xo[i][n_covo] = W[i]*sqrt(sig2);
W[i] *= sqrt(sig2);
}
/* draw tau */
if (Ymax > 1)
for (j = 1; j < Ymax; j++)
tau[j] = runif(taumin[j], taumax[j])*sqrt(sig2);
/* SS matrix */
for(j = 0; j <= n_covo; j++)
for(k = 0; k <= n_covo; k++)
SSo[j][k]=0;
for(i = 0;i < n_samp+n_covo; i++)
for(j = 0;j <= n_covo; j++)
for(k = 0; k <= n_covo; k++)
SSo[j][k] += Xo[i][j]*Xo[i][k];
/* SWEEP SS matrix */
for(j = 0; j < n_covo; j++)
SWP(SSo, j, n_covo+1);
/* draw gamma */
for(j = 0; j < n_covo; j++)
meano[j] = SSo[j][n_covo];
if (*mda)
sig2=(SSo[n_covo][n_covo]+s0)/rchisq((double)n_samp+nu0);
for(j = 0; j < n_covo; j++)
for(k = 0; k < n_covo; k++) Vo[j][k]=-SSo[j][k]*sig2;
rMVN(gamma, meano, Vo, n_covo);
/* rescaling the parameters */
if(*mda) {
for (i = 0; i < n_covo; i++) gamma[i] /= sqrt(sig2);
if (Ymax > 1)
for (i = 1; i < Ymax; i++)
tau[i] /= sqrt(sig2);
}
/* computing smooth terms */
if (*smooth) {
for (i = 0; i < n11; i++) {
treat[i] = 0;
for (j = n_covoX; j < n_covo; j++)
treat[i] += Xo[i][j]*gamma[j];
}
}
/** Compute probabilities **/
for(i = 0; i < n_samp; i++){
vtemp[i] = 0;
for(j = 0; j < n_covo; j++)
vtemp[i] += Xo[i][j]*gamma[j];
}
for(i = 0; i < n_samp; i++){
if(Z[i]==0){
if (C[i] == 1) {
pcmean = vtemp[i];
if (*smooth)
pnmean = vtemp[i]-gamma[0];
else
pnmean = vtemp[i]-gamma[1];
}
else {
if (*smooth)
pcmean = vtemp[i]+gamma[0];
else
pcmean = vtemp[i]+gamma[1];
pnmean = vtemp[i];
}
if (Y[i] == 0){
pc[i] = pnorm(0, pcmean, 1, 1, 0);
pn[i] = pnorm(0, pnmean, 1, 1, 0);
}
else {
if (Ymax == 1) { /* binary probit */
pc[i] = pnorm(0, pcmean, 1, 0, 0);
pn[i] = pnorm(0, pnmean, 1, 0, 0);
}
else { /* ordered probit */
if (Y[i] == Ymax) {
pc[i] = pnorm(tau[Ymax-1], pcmean, 1, 0, 0);
pn[i] = pnorm(tau[Ymax-1], pnmean, 1, 0, 0);
}
else {
pc[i] = pnorm(tau[Y[i]], pcmean, 1, 1, 0) -
pnorm(tau[Y[i]-1], pcmean, 1, 1, 0);
pn[i] = pnorm(tau[Y[i]], pnmean, 1, 1, 0) -
pnorm(tau[Y[i]-1], pnmean, 1, 1, 0);
}
}
}
}
}
/** Compute quantities of interest **/
n_comp = 0; n_compC = 0; n_ncompC = 0; base[0] = 0; base[1] = 0;
for (i = 0; i <= Ymax; i++)
ITTc[i] = 0;
if (*smooth) {
for(i = 0; i < n11; i++){
if(C[i] == 1) {
n_comp++;
if (Z[i] == 0) {
n_compC++;
base[0] += (double)Y[i];
}
pcmean = vtemp[i];
pnmean = vtemp[i]-treat[i]+gamma[0];
ndraw = rnorm(pnmean, 1);
cdraw = rnorm(pcmean, 1);
if (*insample && Ymiss[i]==0)
dtemp = (double)(Y[i]==0) - (double)(ndraw < 0);
else
dtemp = pnorm(0, pcmean, 1, 1, 0) - pnorm(0, pnmean, 1, 1, 0);
ITTc[0] += dtemp;
if (Ymax == 1) { /* binary probit */
if (*insample && Ymiss[i]==0)
dtemp = (double)Y[i] - (double)(ndraw > 0);
else
dtemp = pnorm(0, pcmean, 1, 0, 0) - pnorm(0, pnmean, 1, 0, 0);
ITTc[1] += dtemp;
}
else { /* ordered probit */
if (*insample && Ymiss[i]==0)
dtemp = (double)(Y[i]==Ymax) - (double)(ndraw > tau[Ymax-1]);
else
dtemp = pnorm(tau[Ymax-1], pcmean, 1, 0, 0) -
pnorm(tau[Ymax-1], pnmean, 1, 0, 0);
ITTc[Ymax] += dtemp;
for (j = 1; j < Ymax; j++) {
if (*insample && Ymiss[i]==0)
dtemp = (double)(Y[i]==j) - (double)(ndraw < tau[j] &&
ndraw > tau[j-1]);
else
dtemp = (pnorm(tau[j], pcmean, 1, 1, 0) -
pnorm(tau[j-1], pcmean, 1, 1, 0))
- (pnorm(tau[j], pnmean, 1, 1, 0) -
pnorm(tau[j-1], pnmean, 1, 1, 0));
ITTc[j] += dtemp;
}
}
}
else
if (Z[i] == 0) {
n_ncompC++;
base[1] += (double)Y[i];
}
}
}
else {
for(i = 0; i < n_samp; i++){
if(C[i] == 1) {
n_comp++;
if (Z[i] == 1) {
pcmean = vtemp[i];
pnmean = vtemp[i]-gamma[0]+gamma[1];
}
else {
n_compC++;
base[0] += (double)Y[i];
pcmean = vtemp[i]+gamma[0]-gamma[1];
pnmean = vtemp[i];
}
ndraw = rnorm(pnmean, 1);
cdraw = rnorm(pcmean, 1);
if (*insample && Ymiss[i]==0) {
if (Z[i] == 1)
dtemp = (double)(Y[i]==0) - (double)(ndraw < 0);
else
dtemp = (double)(cdraw < 0) - (double)(Y[i]==0);
}
else
dtemp = pnorm(0, pcmean, 1, 1, 0) - pnorm(0, pnmean, 1, 1, 0);
ITTc[0] += dtemp;
if (Ymax == 1) { /* binary probit */
if (*insample && Ymiss[i]==0) {
if (Z[i] == 1)
dtemp = (double)Y[i] - (double)(ndraw > 0);
else
dtemp = (double)(cdraw > 0) - (double)Y[i];
}
else
dtemp = pnorm(0, pcmean, 1, 0, 0) - pnorm(0, pnmean, 1, 0, 0);
ITTc[1] += dtemp;
}
else { /* ordered probit */
if (*insample && Ymiss[i]==0) {
if (Z[i] == 1)
dtemp = (double)(Y[i]==Ymax) - (double)(ndraw > tau[Ymax-1]);
else
dtemp = (double)(cdraw > tau[Ymax-1]) - (double)(Y[i]==Ymax);
}
else
dtemp = pnorm(tau[Ymax-1], pcmean, 1, 0, 0) -
pnorm(tau[Ymax-1], pnmean, 1, 0, 0);
ITTc[Ymax] += dtemp;
for (j = 1; j < Ymax; j++) {
if (*insample && Ymiss[i]==0) {
if (Z[i] == 1)
dtemp = (double)(Y[i]==j) - (double)(ndraw < tau[j] && ndraw > tau[j-1]);
else
dtemp = (pnorm(tau[j], pcmean, 1, 1, 0) -
pnorm(tau[j-1], pcmean, 1, 1, 0)) - (double)(Y[i]==j);
}
else
dtemp = (pnorm(tau[j], pcmean, 1, 1, 0) -
pnorm(tau[j-1], pcmean, 1, 1, 0))
- (pnorm(tau[j], pnmean, 1, 1, 0) -
pnorm(tau[j-1], pnmean, 1, 1, 0));
ITTc[j] += dtemp;
}
}
}
else
if (Z[i] == 0) {
n_ncompC++;
base[1] += (double)Y[i];
}
}
}
/** storing the results **/
if (main_loop > *iBurnin) {
if (keep == *iKeep) {
pdStore[itemp++]=(double)n_comp/(double)n_samp;
if (Ymax == 1) {
pdStore[itemp++]=ITTc[1]/(double)n_comp;
pdStore[itemp++]=ITTc[1]/(double)n_samp;
pdStore[itemp++] = base[0]/(double)n_compC;
pdStore[itemp++] = base[1]/(double)n_ncompC;
pdStore[itemp++] = (base[0]+base[1])/(double)(n_compC+n_ncompC);
}
else {
for (i = 0; i <= Ymax; i++)
pdStore[itemp++]=ITTc[i]/(double)n_comp;
for (i = 0; i <= Ymax; i++)
pdStore[itemp++]=ITTc[i]/(double)n_samp;
}
if (*param) {
for(i = 0; i < n_cov; i++)
pdStore[itemp++]=beta[i];
if (*smooth) {
for(i = 0; i < n_covoX; i++)
pdStore[itemp++]=gamma[i];
for(i = 0; i < n11; i++)
pdStore[itemp++]=treat[i];
}
else
for(i = 0; i < n_covo; i++)
pdStore[itemp++]=gamma[i];
if (Ymax > 1)
for (i = 0; i < Ymax; i++)
pdStore[itemp++]=tau[i];
}
keep = 1;
}
else
keep++;
}
if(*verbose) {
if(main_loop == itempP) {
Rprintf("%3d percent done.\n", progress*10);
itempP += ftrunc((double) n_gen/10);
progress++;
R_FlushConsole();
}
}
R_FlushConsole();
R_CheckUserInterrupt();
} /* end of Gibbs sampler */
/** write out the random seed **/
PutRNGstate();
/** freeing memory **/
FreeMatrix(X, n_samp+n_cov);
FreeMatrix(Xo, n_samp+n_covo);
free(W);
free(beta);
free(gamma);
free(q);
free(pc);
free(pn);
FreeMatrix(SS, n_cov+1);
FreeMatrix(SSo, n_covo+1);
free(meanb);
free(meano);
free(meanr);
FreeMatrix(V, n_cov);
FreeMatrix(Vo, n_covo);
FreeMatrix(Vr, 3);
FreeMatrix(A, n_cov);
FreeMatrix(Ao, n_covo);
free(tau);
free(taumax);
free(taumin);
free(ITTc);
free(vtemp);
free(treat);
free(base);
FreeMatrix(mtemp, n_cov);
FreeMatrix(mtempo, n_covo);
} /* main */
void hSDM_Nmixture_iCAR (
// Constants and data
const int *ngibbs, int *nthin, int *nburn, // Number of iterations, burning and samples
const int *nobs, int *nsite, int *ncell, // Number of observations, sites and cells
const int *np, // Number of fixed effects for lambda
const int *nq, // Number of fixed effects for delta
const int *Y_vect, // Number of successes (presences)
const double *W_vect, // Observability covariates (nobs x nq)
const double *X_vect, // Suitability covariates (nsite x np)
// Sites
const int *S_vect, // Site Id (nobs)
// Spatial correlation
const int *C_vect, // Cell Id (nsite)
const int *nNeigh, // Number of neighbors for each cell
const int *Neigh_vect, // Vector of neighbors sorted by cell
// Predictions
const int *npred, // Number of predictions
const double *X_pred_vect, // Suitability covariates for predictions (npred x np)
const int *C_pred_vect, // Cell Id for predictions (npred)
// Starting values for M-H
const double *beta_start,
const double *gamma_start,
const double *rho_start,
const int *N_start,
// Parameters
double *beta_vect,
double *gamma_vect,
double *rho_pred,
double *Vrho,
int *N_pred,
// Defining priors
const double *mubeta, double *Vbeta,
const double *mugamma, double *Vgamma,
const double *priorVrho,
const double *shape, double *rate,
const double *Vrho_max,
// Diagnostic
double *Deviance,
double *lambda_latent, // Latent proba of suitability (length NSITE)
double *delta_latent, // Latent proba of observability (length NOBS)
double *lambda_pred, // Proba of suitability for predictions (length NPRED)
// Seeds
const int *seed,
// Verbose
const int *verbose,
// Save rho, p and N
const int *save_rho,
const int *save_p,
const int *save_N
) {
////////////////////////////////////////////////////////////////////////////////
//%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
// Defining and initializing objects
////////////////////////////////////////
// Initialize random number generator //
srand(seed[0]);
///////////////////////////
// Redefining constants //
const int NGIBBS=ngibbs[0];
const int NTHIN=nthin[0];
const int NBURN=nburn[0];
const int NSAMP=(NGIBBS-NBURN)/NTHIN;
const int NOBS=nobs[0];
const int NSITE=nsite[0];
const int NCELL=ncell[0];
const int NP=np[0];
const int NQ=nq[0];
const int NPRED=npred[0];
///////////////////////////////////
// Declaring some useful objects //
double *lambda_run=malloc(NSITE*sizeof(double));
for (int i=0; i<NSITE; i++) {
lambda_run[i]=0.0;
}
double *delta_run=malloc(NOBS*sizeof(double));
for (int n=0; n<NOBS; n++) {
delta_run[n]=0.0;
}
double *lambda_pred_run=malloc(NPRED*sizeof(double));
for (int m=0; m<NPRED; m++) {
lambda_pred_run[m]=0.0;
}
double *N_pred_double=malloc(NSITE*sizeof(double));
for (int i=0; i<NSITE; i++) {
N_pred_double[i]=0.0;
}
//////////////////////////////////////////////////////////
// Set up and initialize structure for density function //
struct dens_par dens_data;
/* Data */
dens_data.NOBS=NOBS;
dens_data.NSITE=NSITE;
// Y
dens_data.Y=malloc(NOBS*sizeof(int));
for (int n=0; n<NOBS; n++) {
dens_data.Y[n]=Y_vect[n];
}
/* Sites */
// IdSiteforObs
dens_data.IdSiteforObs=malloc(NOBS*sizeof(int));
for (int n=0; n<NOBS; n++) {
dens_data.IdSiteforObs[n]=S_vect[n];
}
// nObsSite
dens_data.nObsSite=malloc(NSITE*sizeof(int));
for (int i=0; i<NSITE; i++) {
dens_data.nObsSite[i]=0;
for (int n=0; n<NOBS; n++) {
if (dens_data.IdSiteforObs[n]==i) {
dens_data.nObsSite[i]++;
}
}
}
// ListObsBySite
dens_data.ListObsBySite=malloc(NSITE*sizeof(int*));
for (int i=0; i<NSITE; i++) {
dens_data.ListObsBySite[i]=malloc(dens_data.nObsSite[i]*sizeof(int));
int repSite=0;
for (int n=0; n<NOBS; n++) {
if (dens_data.IdSiteforObs[n]==i) {
dens_data.ListObsBySite[i][repSite]=n;
repSite++;
}
}
}
/* Latent variable */
// N_run
dens_data.N_run=malloc(NSITE*sizeof(int));
for (int i=0; i<NSITE; i++) {
dens_data.N_run[i]=N_start[i];
}
dens_data.pos_N=0;
/* Spatial correlation */
// IdCellforSite
dens_data.IdCellforSite=malloc(NSITE*sizeof(int));
for (int i=0; i<NSITE; i++) {
dens_data.IdCellforSite[i]=C_vect[i];
}
// nSiteCell
dens_data.nSiteCell=malloc(NCELL*sizeof(int));
for (int j=0; j<NCELL; j++) {
dens_data.nSiteCell[j]=0;
for (int i=0; i<NSITE; i++) {
if (dens_data.IdCellforSite[i]==j) {
dens_data.nSiteCell[j]++;
}
}
}
// ListSiteByCell
dens_data.ListSiteByCell=malloc(NCELL*sizeof(int*));
for (int j=0; j<NCELL; j++) {
dens_data.ListSiteByCell[j]=malloc(dens_data.nSiteCell[j]*sizeof(int));
int repCell=0;
for (int i=0; i<NSITE; i++) {
if (dens_data.IdCellforSite[i]==j) {
dens_data.ListSiteByCell[j][repCell]=i;
repCell++;
}
}
}
// Number of neighbors by cell
dens_data.nNeigh=malloc(NCELL*sizeof(int));
for (int j=0; j<NCELL; j++) {
dens_data.nNeigh[j]=nNeigh[j];
}
// Neighbor identifiers by cell
int posNeigh=0;
dens_data.Neigh=malloc(NCELL*sizeof(int*));
for (int j=0; j<NCELL; j++) {
dens_data.Neigh[j]=malloc(nNeigh[j]*sizeof(int));
for (int m=0; m<nNeigh[j]; m++) {
dens_data.Neigh[j][m]=Neigh_vect[posNeigh+m];
}
posNeigh+=nNeigh[j];
}
dens_data.pos_rho=0;
dens_data.rho_run=malloc(NCELL*sizeof(double));
for (int j=0; j<NCELL; j++) {
dens_data.rho_run[j]=rho_start[j];
}
dens_data.shape=shape[0];
dens_data.rate=rate[0];
dens_data.Vrho_run=Vrho[0];
/* Suitability process */
dens_data.NP=NP;
dens_data.pos_beta=0;
dens_data.X=malloc(NSITE*sizeof(double*));
for (int i=0; i<NSITE; i++) {
dens_data.X[i]=malloc(NP*sizeof(double));
for (int p=0; p<NP; p++) {
dens_data.X[i][p]=X_vect[p*NSITE+i];
}
}
dens_data.mubeta=malloc(NP*sizeof(double));
dens_data.Vbeta=malloc(NP*sizeof(double));
for (int p=0; p<NP; p++) {
dens_data.mubeta[p]=mubeta[p];
dens_data.Vbeta[p]=Vbeta[p];
}
dens_data.beta_run=malloc(NP*sizeof(double));
for (int p=0; p<NP; p++) {
dens_data.beta_run[p]=beta_start[p];
}
/* Observability process */
dens_data.NQ=NQ;
dens_data.pos_gamma=0;
dens_data.W=malloc(NOBS*sizeof(double*));
for (int n=0; n<NOBS; n++) {
dens_data.W[n]=malloc(NQ*sizeof(double));
for (int q=0; q<NQ; q++) {
dens_data.W[n][q]=W_vect[q*NOBS+n];
}
}
dens_data.mugamma=malloc(NQ*sizeof(double));
dens_data.Vgamma=malloc(NQ*sizeof(double));
for (int q=0; q<NQ; q++) {
dens_data.mugamma[q]=mugamma[q];
dens_data.Vgamma[q]=Vgamma[q];
}
dens_data.gamma_run=malloc(NQ*sizeof(double));
for (int q=0; q<NQ; q++) {
dens_data.gamma_run[q]=gamma_start[q];
}
/* Visited cell or not */
int *viscell = malloc(NCELL*sizeof(int));
for (int j=0; j<NCELL; j++) {
viscell[j]=0;
}
for (int i=0; i<NSITE; i++) {
viscell[dens_data.IdCellforSite[i]]++;
}
int NVISCELL=0;
for (int j=0; j<NCELL; j++) {
if (viscell[j]>0) {
NVISCELL++;
}
}
/* Predictions */
// IdCell_pred
int *IdCell_pred=malloc(NPRED*sizeof(int));
for (int m=0; m<NPRED; m++) {
IdCell_pred[m]=C_pred_vect[m];
}
// X_pred
double **X_pred=malloc(NPRED*sizeof(double*));
for (int m=0; m<NPRED; m++) {
X_pred[m]=malloc(NP*sizeof(double));
for (int p=0; p<NP; p++) {
X_pred[m][p]=X_pred_vect[p*NPRED+m];
}
}
////////////////////////////////////////////////////////////
// Proposal variance and acceptance for adaptive sampling //
// beta
double *sigmap_beta = malloc(NP*sizeof(double));
int *nA_beta = malloc(NP*sizeof(int));
double *Ar_beta = malloc(NP*sizeof(double)); // Acceptance rate
for (int p=0; p<NP; p++) {
nA_beta[p]=0;
sigmap_beta[p]=1.0;
Ar_beta[p]=0.0;
}
// gamma
double *sigmap_gamma = malloc(NQ*sizeof(double));
int *nA_gamma = malloc(NQ*sizeof(int));
double *Ar_gamma = malloc(NQ*sizeof(double)); // Acceptance rate
for (int q=0; q<NQ; q++) {
nA_gamma[q]=0;
sigmap_gamma[q]=1.0;
Ar_gamma[q]=0.0;
}
// rho
double *sigmap_rho = malloc(NCELL*sizeof(double));
int *nA_rho = malloc(NCELL*sizeof(int));
double *Ar_rho = malloc(NCELL*sizeof(double)); // Acceptance rate
for (int i=0; i<NCELL; i++) {
nA_rho[i]=0;
sigmap_rho[i]=1.0;
Ar_rho[i]=0.0;
}
// N
int *nA_N = malloc(NSITE*sizeof(int));
double *Ar_N = malloc(NSITE*sizeof(double)); // Acceptance rate
for (int i=0; i<NSITE; i++) {
nA_N[i]=0;
Ar_N[i]=0.0;
}
////////////
// Message//
Rprintf("\nRunning the Gibbs sampler. It may be long, please keep cool :)\n\n");
R_FlushConsole();
//R_ProcessEvents(); for windows
///////////////////////////////////////////////////////////////////////////////////////
//%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
// Gibbs sampler
for (int g=0; g<NGIBBS; g++) {
////////////////////////////////////////////////
// beta
for (int p=0; p<NP; p++) {
dens_data.pos_beta=p; // Specifying the rank of the parameter of interest
double x_now=dens_data.beta_run[p];
double x_prop=myrnorm(x_now,sigmap_beta[p]);
double p_now=betadens(x_now, &dens_data);
double p_prop=betadens(x_prop, &dens_data);
double r=exp(p_prop-p_now); // ratio
double z=myrunif();
// Actualization
if (z < r) {
dens_data.beta_run[p]=x_prop;
nA_beta[p]++;
}
}
////////////////////////////////////////////////
// gamma
for (int q=0; q<NQ; q++) {
dens_data.pos_gamma=q; // Specifying the rank of the parameter of interest
double x_now=dens_data.gamma_run[q];
double x_prop=myrnorm(x_now,sigmap_gamma[q]);
double p_now=gammadens(x_now, &dens_data);
double p_prop=gammadens(x_prop, &dens_data);
double r=exp(p_prop-p_now); // ratio
double z=myrunif();
// Actualization
if (z < r) {
dens_data.gamma_run[q]=x_prop;
nA_gamma[q]++;
}
}
////////////////////////////////////////////////
// rho
/* Sampling rho_run[j] */
for (int j=0; j<NCELL; j++) {
dens_data.pos_rho=j; // Specifying the rank of the parameter of interest
if (viscell[j]>0) {
double x_now=dens_data.rho_run[j];
double x_prop=myrnorm(x_now,sigmap_rho[j]);
double p_now=rhodens_visited(x_now, &dens_data);
double p_prop=rhodens_visited(x_prop, &dens_data);
double r=exp(p_prop-p_now); // ratio
double z=myrunif();
// Actualization
if (z < r) {
dens_data.rho_run[j]=x_prop;
nA_rho[j]++;
}
}
else {
dens_data.rho_run[j]=rhodens_unvisited(&dens_data);
}
}
/* Centering rho_run[j] */
double rho_sum=0.0;
for (int j=0; j<NCELL; j++) {
rho_sum+=dens_data.rho_run[j];
}
double rho_bar=rho_sum/NCELL;
for (int j=0; j<NCELL; j++) {
dens_data.rho_run[j]=dens_data.rho_run[j]-rho_bar;
}
////////////////////////////////////////////////
// Vrho
if (priorVrho[0]>0.0) { // fixed value for Vrho
dens_data.Vrho_run=priorVrho[0];
}
else {
double Sum=0.0;
for (int j=0; j<NCELL; j++) {
double Sum_neigh=0.0;
double nNeigh=dens_data.nNeigh[j];
double rho_run=dens_data.rho_run[j];
for (int m=0; m<nNeigh; m++) {
Sum_neigh += dens_data.rho_run[dens_data.Neigh[j][m]];
}
Sum += rho_run*(nNeigh*rho_run-Sum_neigh);
}
if (priorVrho[0]==-1.0) { // prior = 1/Gamma(shape,rate)
double Shape=shape[0]+0.5*(NCELL-1);
double Rate=rate[0]+0.5*Sum;
dens_data.Vrho_run=Rate/myrgamma1(Shape);
}
if (priorVrho[0]==-2.0) { // prior = Uniform(0,Vrho_max)
double Shape=0.5*NCELL-1;
double Rate=0.5*Sum;
dens_data.Vrho_run=1/myrtgamma_left(Shape,Rate,1/Vrho_max[0]);
}
}
////////////////////////////////////////////////
// N
for (int i=0; i<NSITE; i++) {
dens_data.pos_N=i; // Specifying the rank of the parameter of interest
int x_now=dens_data.N_run[i];
if (x_now==0) {
double s=myrunif();
if (s < 0.5) {
//dens_data.N_run[i]=x_now;
dens_data.N_run[i]=0;
}
else {
// Proposal
//int x_prop=x_now+1;
int x_prop=1;
// Ratio
double p_now=Ndens(x_now, &dens_data);
double p_prop=Ndens(x_prop, &dens_data);
double r=exp(p_prop-p_now);
// Actualization
double z=myrunif();
if (z < r) {
dens_data.N_run[i]=x_prop;
nA_N[i]++;
}
}
}
else {
// Proposal
double s=myrunif();
int x_prop=0;
if (s < 0.5) x_prop=x_now-1;
else x_prop=x_now+1;
// Ratio
double p_now=Ndens(x_now, &dens_data);
double p_prop=Ndens(x_prop, &dens_data);
double r=exp(p_prop-p_now);
// Actualization
double z=myrunif();
if (z < r) {
dens_data.N_run[i]=x_prop;
nA_N[i]++;
}
}
}
//////////////////////////////////////////////////
// Deviance
// logLikelihood
double logL1=0.0;
for (int n=0; n<NOBS; n++) {
int ws=dens_data.IdSiteforObs[n]; // which site
/* delta */
double logit_delta=0.0;
for (int q=0; q<NQ; q++) {
logit_delta+=dens_data.W[n][q]*dens_data.gamma_run[q];
}
delta_run[n]=invlogit(logit_delta);
/* log Likelihood */
logL1+=dbinom(dens_data.Y[n],dens_data.N_run[ws],delta_run[n],1);
}
double logL2=0.0;
for (int i=0; i<NSITE; i++) {
int wc=dens_data.IdCellforSite[i]; // which cell
/* lambda */
double Xpart_lambda=0.0;
for (int p=0; p<NP; p++) {
Xpart_lambda+=dens_data.X[i][p]*dens_data.beta_run[p];
}
lambda_run[i]=exp(Xpart_lambda+dens_data.rho_run[wc]);
logL2+=dpois(dens_data.N_run[i],lambda_run[i],1);
}
double logL=logL1+logL2;
// Deviance
double Deviance_run=-2*logL;
//////////////////////////////////////////////////
// Predictions
for (int m=0; m<NPRED; m++) {
/* lambda_pred_run */
double Xpart_lambda_pred=0.0;
for (int p=0; p<NP; p++) {
Xpart_lambda_pred+=X_pred[m][p]*dens_data.beta_run[p];
}
lambda_pred_run[m]=exp(Xpart_lambda_pred+dens_data.rho_run[IdCell_pred[m]]);
}
//////////////////////////////////////////////////
// Output
if (((g+1)>NBURN) && (((g+1)%(NTHIN))==0)) {
int isamp=((g+1)-NBURN)/(NTHIN);
// beta
for (int p=0; p<NP; p++) {
beta_vect[p*NSAMP+(isamp-1)]=dens_data.beta_run[p];
}
// gamma
for (int q=0; q<NQ; q++) {
gamma_vect[q*NSAMP+(isamp-1)]=dens_data.gamma_run[q];
}
// Deviance
Deviance[isamp-1]=Deviance_run;
for (int i=0; i<NSITE; i++) {
lambda_latent[i]+=lambda_run[i]/NSAMP; // We compute the mean of NSAMP values
}
for (int n=0; n<NOBS; n++) {
delta_latent[n]+=delta_run[n]/NSAMP; // We compute the mean of NSAMP values
}
// rho
if (save_rho[0]==0) { // We compute the mean of NSAMP values
for (int j=0; j<NCELL; j++) {
rho_pred[j]+=dens_data.rho_run[j]/NSAMP;
}
}
if (save_rho[0]==1) { // The NSAMP sampled values for rhos are saved
for (int j=0; j<NCELL; j++) {
rho_pred[j*NSAMP+(isamp-1)]=dens_data.rho_run[j];
}
}
// lambda_pred
if (save_p[0]==0) { // We compute the mean of NSAMP values
for (int m=0; m<NPRED; m++) {
lambda_pred[m]+=lambda_pred_run[m]/NSAMP;
}
}
if (save_p[0]==1) { // The NSAMP sampled values for lambda are saved
for (int m=0; m<NPRED; m++) {
lambda_pred[m*NSAMP+(isamp-1)]=lambda_pred_run[m];
}
}
// Vrho
Vrho[isamp-1]=dens_data.Vrho_run;
// N
if (save_N[0]==0) { // We compute the mean of NSAMP values
for (int i=0; i<NSITE; i++) {
N_pred_double[i]+= ((double) dens_data.N_run[i])/NSAMP;
}
}
if (save_N[0]==1) { // The NSAMP sampled values for lambda are saved
for (int i=0; i<NSITE; i++) {
N_pred[i*NSAMP+(isamp-1)]=dens_data.N_run[i];
}
}
}
///////////////////////////////////////////////////////
// Adaptive sampling (on the burnin period)
const double ropt=0.234;
int DIV=0;
if (NGIBBS >=1000) DIV=100;
else DIV=NGIBBS/10;
/* During the burnin period */
if ((g+1)%DIV==0 && (g+1)<=NBURN) {
// beta
for (int p=0; p<NP; p++) {
Ar_beta[p]=((double) nA_beta[p])/DIV;
if(Ar_beta[p]>=ropt) sigmap_beta[p]=sigmap_beta[p]*(2-(1-Ar_beta[p])/(1-ropt));
else sigmap_beta[p]=sigmap_beta[p]/(2-Ar_beta[p]/ropt);
nA_beta[p]=0.0; // We reinitialize the number of acceptance to zero
}
// gamma
for (int q=0; q<NQ; q++) {
Ar_gamma[q]=((double) nA_gamma[q])/DIV;
if(Ar_gamma[q]>=ropt) sigmap_gamma[q]=sigmap_gamma[q]*(2-(1-Ar_gamma[q])/(1-ropt));
else sigmap_gamma[q]=sigmap_gamma[q]/(2-Ar_gamma[q]/ropt);
nA_gamma[q]=0.0; // We reinitialize the number of acceptance to zero
}
// rho
for (int j=0; j<NCELL; j++) {
if (viscell[j]>0) {
Ar_rho[j]=((double) nA_rho[j])/DIV;
if(Ar_rho[j]>=ropt) sigmap_rho[j]=sigmap_rho[j]*(2-(1-Ar_rho[j])/(1-ropt));
else sigmap_rho[j]=sigmap_rho[j]/(2-Ar_rho[j]/ropt);
nA_rho[j]=0.0; // We reinitialize the number of acceptance to zero
}
}
// N
for (int i=0; i<NSITE; i++) {
Ar_N[i]=((double) nA_N[i])/DIV;
nA_N[i]=0.0; // We reinitialize the number of acceptance to zero
}
}
/* After the burnin period */
if ((g+1)%DIV==0 && (g+1)>NBURN) {
// beta
for (int p=0; p<NP; p++) {
Ar_beta[p]=((double) nA_beta[p])/DIV;
nA_beta[p]=0.0; // We reinitialize the number of acceptance to zero
}
// gamma
for (int q=0; q<NQ; q++) {
Ar_gamma[q]=((double) nA_gamma[q])/DIV;
nA_gamma[q]=0.0; // We reinitialize the number of acceptance to zero
}
// rho
for (int j=0; j<NCELL; j++) {
if (viscell[j]>0) {
Ar_rho[j]=((double) nA_rho[j])/DIV;
nA_rho[j]=0.0; // We reinitialize the number of acceptance to zero
}
}
// N
for (int i=0; i<NSITE; i++) {
Ar_N[i]=((double) nA_N[i])/DIV;
nA_N[i]=0.0; // We reinitialize the number of acceptance to zero
}
}
//////////////////////////////////////////////////
// Progress bar
double Perc=100*(g+1)/(NGIBBS);
if (((g+1)%(NGIBBS/100))==0 && verbose[0]==1) {
Rprintf("*");
R_FlushConsole();
//R_ProcessEvents(); for windows
if (((g+1)%(NGIBBS/10))==0) {
double mAr_beta=0; // Mean acceptance rate
double mAr_gamma=0;
double mAr_rho=0;
double mAr_N=0;
// beta
for (int p=0; p<NP; p++) {
mAr_beta+=Ar_beta[p]/NP;
}
// gamma
for (int q=0; q<NQ; q++) {
mAr_gamma+=Ar_gamma[q]/NQ;
}
// rho
for (int j=0; j<NCELL; j++) {
if (viscell[j]>0) {
mAr_rho+=Ar_rho[j]/NVISCELL;
}
}
// N
for (int i=0; i<NSITE; i++) {
mAr_N+=Ar_N[i]/NSITE;
}
Rprintf(":%.1f%%, mean accept. rates= beta:%.3f, gamma:%.3f, rho:%.3f, N:%.3f\n",Perc,mAr_beta,mAr_gamma,mAr_rho,mAr_N);
R_FlushConsole();
//R_ProcessEvents(); for windows
}
}
//////////////////////////////////////////////////
// User interrupt
R_CheckUserInterrupt(); // allow user interrupt
} // Gibbs sampler
//////////////////////////
// Rounding N_pred if save.N==0
if (save_N[0]==0) {
for (int i=0; i<NSITE; i++) {
N_pred[i]= (int)(N_pred_double[i] < 0 ? (N_pred_double[i]-0.5):(N_pred_double[i]+0.5));
}
}
///////////////
// Delete memory allocation (see malloc())
/* Obs */
free(dens_data.Y);
/* Site */
free(dens_data.IdSiteforObs);
free(dens_data.nObsSite);
for (int i=0; i<NSITE; i++) {
free(dens_data.ListObsBySite[i]);
}
free(dens_data.ListObsBySite);
/* Latent variable */
free(dens_data.N_run);
free(N_pred_double);
/* Spatial correlation */
free(dens_data.IdCellforSite);
free(dens_data.nSiteCell);
for (int j=0; j<NCELL; j++) {
free(dens_data.ListSiteByCell[j]);
}
free(dens_data.ListSiteByCell);
free(dens_data.nNeigh);
for (int j=0; j<NCELL; j++) {
free(dens_data.Neigh[j]);
}
free(dens_data.Neigh);
free(dens_data.rho_run);
free(viscell);
/* Suitability */
for (int i=0; i<NSITE; i++) {
free(dens_data.X[i]);
}
free(dens_data.X);
free(dens_data.mubeta);
free(dens_data.Vbeta);
free(dens_data.beta_run);
free(lambda_run);
/* Observability */
for (int n=0; n<NOBS; n++) {
free(dens_data.W[n]);
}
free(dens_data.W);
free(dens_data.mugamma);
free(dens_data.Vgamma);
free(dens_data.gamma_run);
free(delta_run);
/* Predictions */
free(IdCell_pred);
for (int m=0; m<NPRED; m++) {
free(X_pred[m]);
}
free(X_pred);
free(lambda_pred_run);
/* Adaptive MH */
free(sigmap_beta);
free(nA_beta);
free(Ar_beta);
free(sigmap_gamma);
free(nA_gamma);
free(Ar_gamma);
free(sigmap_rho);
free(nA_rho);
free(Ar_rho);
free(nA_N);
free(Ar_N);
} // end hSDM function
/* ML estimation of parameters in mixture model via EM; maximum-likelihood
* estimation of parameters in the mixture model via the EM algorithm, using
* multilocus information, but assuming known recombination frequencies
*/
double QTLmixture(MQMMarkerMatrix loci, cvector cofactor, vector r, cvector position,
vector y, ivector ind, int Nind, int Naug,
int Nloci,
double *variance, int em, vector *weight, const bool useREML,const bool fitQTL,const bool dominance, MQMCrossType crosstype, int verbose) {
//debug_trace("QTLmixture called Nloci=%d Nind=%d Naug=%d, REML=%d em=%d fit=%d domi=%d cross=%c\n",Nloci,Nind,Naug,useREML,em,fitQTL,dominance,crosstype);
//for (int i=0; i<Nloci; i++){ debug_trace("loci %d : recombfreq=%f\n",i,r[i]); }
int iem= 0, i, j;
bool warnZeroDist=false;
bool biasadj=false;
double oldlogL=-10000, delta=1.0, calc_i, Pscale=1.75;
vector indweight = newvector(Nind);
int newNaug = ((!fitQTL) ? Naug : 3*Naug);
vector Fy = newvector(newNaug);
double logP = Nloci*log(Pscale); // only for computational accuracy
bool varknown = (((*variance)==-1.0) ? false : true );
vector Ploci = newvector(newNaug);
#ifndef STANDALONE
R_CheckUserInterrupt(); /* check for ^C */
R_FlushConsole();
#endif
if (!useREML) {
varknown=false;
biasadj=false;
}
for (i=0; i<newNaug; i++) { Ploci[i]= 1.0; }
if (!fitQTL) {
for (j=0; j<Nloci; j++) {
for (i=0; i<Naug; i++)
Ploci[i]*= Pscale;
if ((position[j]==MLEFT)||(position[j]==MUNLINKED)) {
for (i=0; i<Naug; i++) {
calc_i = start_prob(crosstype, loci[j][i]); // calc_i= prob(loci, r, i, j, MH, crosstype, 0, 1);
Ploci[i]*= calc_i;
//Als Ploci > 0 en calc_i > 0 then we want to assert Ploci[] != 0
}
}
if ((position[j]==MLEFT)||(position[j]==MMIDDLE)) {
for (i=0; i<Naug; i++) {
calc_i =left_prob(r[j],loci[j][i],loci[j+1][i],crosstype); //calc_i = prob(loci, r, i, j, loci[j+1][i], crosstype, 0);
if(calc_i == 0.0){calc_i=1.0;warnZeroDist=true;}
Ploci[i]*= calc_i;
}
}
}
} else {
for (j=0; j<Nloci; j++) {
for (i=0; i<Naug; i++) {
Ploci[i]*= Pscale; // only for computational accuracy; see use of logP
Ploci[i+Naug]*= Pscale; // only for computational accuracy; see use of logP
Ploci[i+2*Naug]*= Pscale; // only for computational accuracy; see use of logP
}
if ((position[j]==MLEFT)||(position[j]==MUNLINKED)) {
if (cofactor[j]<=MCOF){
for (i=0; i<Naug; i++) {
calc_i = start_prob(crosstype, loci[j][i]); // calc_i= prob(loci, r, i, j, MH, crosstype, 0, 1);
Ploci[i] *= calc_i;
Ploci[i+Naug] *= calc_i;
Ploci[i+2*Naug] *= calc_i;
}
}else{
for (i=0; i<Naug; i++) {
Ploci[i]*= start_prob(crosstype, MAA); //startvalue for MAA for new chromosome
Ploci[i+Naug]*= start_prob(crosstype, MH); //startvalue for MH for new chromosome
Ploci[i+2*Naug] *= start_prob(crosstype, MBB); //startvalue for MBB for new chromosome
}
}
}
if ((position[j]==MLEFT)||(position[j]==MMIDDLE)) {
if ((cofactor[j]<=MCOF)&&(cofactor[j+1]<=MCOF))
for (i=0; i<Naug; i++) {
calc_i =left_prob(r[j],loci[j][i],loci[j+1][i],crosstype); //calc_i = prob(loci, r, i, j, loci[j+1][i], crosstype, 0);
if(calc_i == 0.0){calc_i=1.0;warnZeroDist=true;}
Ploci[i]*= calc_i;
Ploci[i+Naug]*= calc_i;
Ploci[i+2*Naug]*= calc_i;
}
else if (cofactor[j]<=MCOF) // locus j+1 == QTL
for (i=0; i<Naug; i++) { // QTL==MAA || MH || MBB means: What is the prob of finding an MAA at J=1
calc_i =left_prob(r[j],loci[j][i],MAA,crosstype); //calc_i = prob(loci, r, i, j, MAA, crosstype, 0);
Ploci[i]*= calc_i;
calc_i = left_prob(r[j],loci[j][i],MH,crosstype); //calc_i = prob(loci, r, i, j, MH, crosstype, 0);
Ploci[i+Naug]*= calc_i;
calc_i = left_prob(r[j],loci[j][i],MBB,crosstype); //calc_i = prob(loci, r, i, j, MBB, crosstype, 0);
Ploci[i+2*Naug]*= calc_i;
}
else // locus j == QTL
for (i=0; i<Naug; i++) { // QTL==MQTL
calc_i = left_prob(r[j],MAA,loci[j+1][i],crosstype); //calc_i = prob(loci, r, i, j+1, MAA, crosstype, -1);
Ploci[i]*= calc_i;
calc_i = left_prob(r[j],MH,loci[j+1][i],crosstype); //calc_i = prob(loci, r, i, j+1, MH, crosstype, -1);
Ploci[i+Naug]*= calc_i;
calc_i = left_prob(r[j],MBB,loci[j+1][i],crosstype); //calc_i = prob(loci, r, i, j+1, MBB, crosstype, -1);
Ploci[i+2*Naug]*= calc_i;
}
}
}
}
if(warnZeroDist)info("!!! 0.0 from Prob !!! Markers at same Cm but different genotype !!!");
// Rprintf("INFO: Done fitting QTL's\n");
if ((*weight)[0]== -1.0) {
for (i=0; i<Nind; i++) indweight[i]= 0.0;
if (!fitQTL) {
for (i=0; i<Naug; i++) indweight[ind[i]]+=Ploci[i];
for (i=0; i<Naug; i++) (*weight)[i]= Ploci[i]/indweight[ind[i]];
} else {
for (i=0; i<Naug; i++) indweight[ind[i]]+=Ploci[i]+Ploci[i+Naug]+Ploci[i+2*Naug];
for (i=0; i<Naug; i++) {
(*weight)[i] = Ploci[i]/indweight[ind[i]];
(*weight)[i+Naug] = Ploci[i+Naug]/indweight[ind[i]];
(*weight)[i+2*Naug]= Ploci[i+2*Naug]/indweight[ind[i]];
}
}
}
debug_trace("Weights done\n");
debug_trace("Individual->trait,indweight weight Ploci\n");
//for (int j=0; j<Nind; j++){
// debug_trace("%d->%f,%f %f %f\n", j, y[j],indweight[i], (*weight)[j], Ploci[j]);
//}
double logL = 0;
vector indL = newvector(Nind);
while ((iem<em)&&(delta>1.0e-5)) {
iem+=1;
if (!varknown) *variance=-1.0;
logL = regression(Nind, Nloci, cofactor, loci, y, weight, ind, Naug, variance, Fy, biasadj, fitQTL, dominance);
logL = 0.0;
for (i=0; i<Nind; i++) indL[i]= 0.0;
if (!fitQTL) // no QTL fitted
for (i=0; i<Naug; i++) {
(*weight)[i]= Ploci[i]*Fy[i];
indL[ind[i]]= indL[ind[i]] + (*weight)[i];
}
else // QTL moved along the chromosomes
for (i=0; i<Naug; i++) {
(*weight)[i]= Ploci[i]*Fy[i];
(*weight)[i+Naug] = Ploci[i+Naug]* Fy[i+Naug];
(*weight)[i+2*Naug]= Ploci[i+2*Naug]*Fy[i+2*Naug];
indL[ind[i]]+=(*weight)[i]+(*weight)[i+Naug]+(*weight)[i+2*Naug];
}
for (i=0; i<Nind; i++) logL+=log(indL[i])-logP;
for (i=0; i<Nind; i++) indweight[i]= 0.0;
if (!fitQTL) {
for (i=0; i<Naug; i++) indweight[ind[i]]+=(*weight)[i];
for (i=0; i<Naug; i++) (*weight)[i]/=indweight[ind[i]];
} else {
for (i=0; i<Naug; i++)
indweight[ind[i]]+=(*weight)[i]+(*weight)[i+Naug]+(*weight)[i+2*Naug];
for (i=0; i<Naug; i++) {
(*weight)[i] /=indweight[ind[i]];
(*weight)[i+Naug] /=indweight[ind[i]];
(*weight)[i+2*Naug]/=indweight[ind[i]];
}
}
delta= fabs(logL-oldlogL);
oldlogL= logL;
}
if ((useREML)&&(!varknown)) { // Bias adjustment after finished ML estimation via EM
*variance=-1.0;
biasadj=true;
logL = regression(Nind, Nloci, cofactor, loci, y, weight, ind, Naug, variance, Fy, biasadj, fitQTL, dominance);
logL = 0.0;
for (int _i=0; _i<Nind; _i++) indL[_i]= 0.0;
if (!fitQTL)
for (i=0; i<Naug; i++) {
(*weight)[i]= Ploci[i]*Fy[i];
indL[ind[i]]+=(*weight)[i];
}
else
for (i=0; i<Naug; i++) {
(*weight)[i]= Ploci[i]*Fy[i];
(*weight)[i+Naug]= Ploci[i+Naug]*Fy[i+Naug];
(*weight)[i+2*Naug]= Ploci[i+2*Naug]*Fy[i+2*Naug];
indL[ind[i]]+=(*weight)[i];
indL[ind[i]]+=(*weight)[i+Naug];
indL[ind[i]]+=(*weight)[i+2*Naug];
}
for (i=0; i<Nind; i++) logL+=log(indL[i])-logP;
for (i=0; i<Nind; i++) indweight[i]= 0.0;
if (!fitQTL) {
for (i=0; i<Naug; i++) indweight[ind[i]]+=(*weight)[i];
for (i=0; i<Naug; i++) (*weight)[i]/=indweight[ind[i]];
} else {
for (i=0; i<Naug; i++) {
indweight[ind[i]]+=(*weight)[i];
indweight[ind[i]]+=(*weight)[i+Naug];
indweight[ind[i]]+=(*weight)[i+2*Naug];
}
for (i=0; i<Naug; i++) {
(*weight)[i] /=indweight[ind[i]];
(*weight)[i+Naug] /=indweight[ind[i]];
(*weight)[i+2*Naug]/=indweight[ind[i]];
}
}
}
//for (i=0; i<Nind; i++){ debug_trace("IND %d Ploci: %f Fy: %f UNLOG:%f LogL:%f LogL-LogP: %f\n", i, Ploci[i], Fy[i], indL[i], log(indL[i]), log(indL[i])-logP); }
Free(Fy);
Free(Ploci);
Free(indweight);
Free(indL);
return logL;
}
/*********************
void WtSANSample
Using the parameters contained in the array theta, obtain the
network statistics for a sample of size samplesize. burnin is the
initial number of Markov chain steps before sampling anything
and interval is the number of MC steps between successive
networks in the sample. Put all the sampled statistics into
the networkstatistics array.
*********************/
WtMCMCStatus WtSANSample (WtMHproposal *MHp,
double *theta, double *invcov, double *tau, double *networkstatistics,
int samplesize, int burnin,
int interval, int fVerbose, int nmax,
WtNetwork *nwp, WtModel *m) {
int staken, tottaken, ptottaken;
/*********************
networkstatistics are modified in groups of m->n_stats, and they
reflect the CHANGE in the values of the statistics from the
original (observed) network. Thus, when we begin, the initial
values of the first group of m->n_stats networkstatistics should
all be zero
*********************/
/*for (j=0; j < m->n_stats; j++) */
/* networkstatistics[j] = 0.0; */
/* Rprintf("\n"); */
/* for (j=0; j < m->n_stats; j++){ */
/* Rprintf("j %d %f\n",j,networkstatistics[j]); */
/* } */
/* Rprintf("\n"); */
/*********************
Burn in step. While we're at it, use burnin statistics to
prepare covariance matrix for Mahalanobis distance calculations
in subsequent calls to M-H
*********************/
/* Catch more edges than we can return */
if(WtSANMetropolisHastings(MHp, theta, invcov, tau, networkstatistics, burnin, &staken,
fVerbose, nwp, m)!=WtMCMC_OK)
return WtMCMC_MH_FAILED;
if(nmax!=0 && nwp->nedges >= nmax-1){
return WtMCMC_TOO_MANY_EDGES;
}
if (fVerbose){
Rprintf("Returned from SAN Metropolis-Hastings burnin\n");
}
if (samplesize>1){
staken = 0;
tottaken = 0;
ptottaken = 0;
/* Now sample networks */
for (unsigned int i=1; i < samplesize; i++){
/* Set current vector of stats equal to previous vector */
for (unsigned int j=0; j<m->n_stats; j++){
networkstatistics[j+m->n_stats] = networkstatistics[j];
}
networkstatistics += m->n_stats;
/* This then adds the change statistics to these values */
if(WtSANMetropolisHastings (MHp, theta, invcov, tau, networkstatistics,
interval, &staken, fVerbose, nwp, m)!=WtMCMC_OK)
return WtMCMC_MH_FAILED;
if(nmax!=0 && nwp->nedges >= nmax-1){
return WtMCMC_TOO_MANY_EDGES;
}
tottaken += staken;
if (fVerbose){
if( ((3*i) % samplesize)==0 && samplesize > 500){
Rprintf("Sampled %d from SAN Metropolis-Hastings\n", i);}
}
if( ((3*i) % samplesize)==0 && tottaken == ptottaken){
ptottaken = tottaken;
Rprintf("Warning: SAN Metropolis-Hastings algorithm has accepted only "
"%d steps out of a possible %d\n", ptottaken-tottaken, i);
}
#ifdef Win32
if( ((100*i) % samplesize)==0 && samplesize > 500){
R_FlushConsole();
R_ProcessEvents();
}
#endif
}
/*********************
Below is an extremely crude device for letting the user know
when the chain doesn't accept many of the proposed steps.
*********************/
if (fVerbose){
Rprintf("SAN Metropolis-Hastings accepted %7.3f%% of %d proposed steps.\n",
tottaken*100.0/(1.0*interval*samplesize), interval*samplesize);
}
}else{
if (fVerbose){
Rprintf("SAN Metropolis-Hastings accepted %7.3f%% of %d proposed steps.\n",
staken*100.0/(1.0*burnin), burnin);
}
}
return WtMCMC_OK;
}
void attribute_hidden Rstd_CleanUp(SA_TYPE saveact, int status, int runLast)
{
if(saveact == SA_DEFAULT) /* The normal case apart from R_Suicide */
saveact = SaveAction;
if(saveact == SA_SAVEASK) {
if(R_Interactive) {
unsigned char buf[1024];
qask:
R_ClearerrConsole();
R_FlushConsole();
int res = R_ReadConsole("Save workspace image? [y/n/c]: ",
buf, 128, 0);
if(res) {
switch (buf[0]) {
case 'y':
case 'Y':
saveact = SA_SAVE;
break;
case 'n':
case 'N':
saveact = SA_NOSAVE;
break;
case 'c':
case 'C':
jump_to_toplevel();
break;
default:
goto qask;
}
} else saveact = SA_NOSAVE; /* probably EOF */
} else
saveact = SaveAction;
}
switch (saveact) {
case SA_SAVE:
if(runLast) R_dot_Last();
if(R_DirtyImage) R_SaveGlobalEnv();
#ifdef HAVE_LIBREADLINE
# ifdef HAVE_READLINE_HISTORY_H
if(R_Interactive && UsingReadline) {
int err;
R_setupHistory(); /* re-read the history size and filename */
stifle_history(R_HistorySize);
err = write_history(R_HistoryFile);
if(err) warning(_("problem in saving the history file '%s'"),
R_HistoryFile);
}
# endif /* HAVE_READLINE_HISTORY_H */
#endif /* HAVE_LIBREADLINE */
break;
case SA_NOSAVE:
if(runLast) R_dot_Last();
break;
case SA_SUICIDE:
default:
break;
}
R_RunExitFinalizers();
CleanEd();
if(saveact != SA_SUICIDE) KillAllDevices();
R_CleanTempDir();
if(saveact != SA_SUICIDE && R_CollectWarnings)
PrintWarnings(); /* from device close and (if run) .Last */
if(ifp) fclose(ifp); /* input file from -f or --file= */
fpu_setup(FALSE);
exit(status);
}