/* assemble call as string in C code */
void menu_ttest2()
{
char cmd[256];
done = 0;
create_dialog();
setaction(bCancel, cancel2);
show(win);
for(;;) {
R_WaitEvent();
R_ProcessEvents();
if(done > 0) break;
}
if(done == 1) {
sprintf(cmd, "t.test(x=%s, y=%s, alternative=\"%s\",\n paired=%s, var.equal=%s, conf.level=%s)\n", v[0], v[1],
alts[getlistitem(alt)],
ischecked(paired) ? "TRUE" : "FALSE",
ischecked(varequal) ? "TRUE" : "FALSE",
GA_gettext(lvl));
Rconsolecmd(cmd);
}
hide(win);
delobj(bApply);
delobj(win);
}
/* Fill a text buffer with user typed console input. */
int
R_ReadConsole(const char *prompt, unsigned char *buf, int len,
int addtohistory)
{
R_ProcessEvents();
return TrueReadConsole(prompt, (char *) buf, len, addtohistory);
}
int
rpipeGetc(rpipe * r)
{
DWORD a, b;
char c;
if (!r)
return NOLAUNCH;
while (PeekNamedPipe(r->read, NULL, 0, NULL, &a, NULL)) {
if (!a && !r->active) {
/* I got a case in which process terminated after Peek.. */
PeekNamedPipe(r->read, NULL, 0, NULL, &a, NULL);
if (!a) return NOLAUNCH;/* end of pipe */
}
if (a) {
if (ReadFile(r->read, &c, 1, &b, NULL) == TRUE)
return c;
else
return NOLAUNCH;/* error but...treated as eof */
}
/* we want to look for user break here */
while (peekevent()) doevent();
if (UserBreak) {
rpipeTerminate(r);
break;
}
R_ProcessEvents();
Sleep(100);
}
return NOLAUNCH; /* again.. */
}
static void eventloop(editor c)
{
while (fix_editor_up) {
/* avoid consuming 100% CPU time here */
Sleep(10);
R_ProcessEvents();
}
}
void editorcleanall(void)
{
int i;
for (i = neditors-1; i >= 0; --i) {
if (editorchecksave(REditors[i])) {
R_ProcessEvents(); // see R_CleanUp
jump_to_toplevel();
}
del(REditors[i]);
}
}
void topmodel(double *parameters,
double *topidx,
double *delay,
double *rain,
double *ET0,
double *Qobs,
int *nidxclass,
int *ntimestep,
int *iterations,
int *nch,
int *whattoreturn,
double *perfNS,
double *result)
{
int i,j;
topmodel_topidx_calc(topidx, *nidxclass);
topmodel_memory_allocation(*nch, *ntimestep, *nidxclass);
if(*iterations > 1) Rprintf("Iteration: ");
#ifdef win32
R_flushConsole();
R_ProcessEvents();
#endif
for(i=0; i<*iterations; i++) {
R_CheckUserInterrupt();
if(*iterations > 1) Rprintf ("\b\b\b\b\b\b\b\b%8i",i+1);
topmodel_init(parameters, delay, *nch, i, *nidxclass, *ntimestep);
/* run the model for each time step */
for(j=0; j<*ntimestep; j++)
topmodel_run(rain,ET0,*nidxclass,j,*ntimestep);
/* TODO: separate routing */
/* return simulations? */
if(whattoreturn[0] > 0) {
topmodel_output(result, *ntimestep, *iterations, whattoreturn[0], *nidxclass, i);
}
/* return NS? */
if(whattoreturn[1]) {
perfNS[i] = NS(misc.Qt, Qobs, *ntimestep);
}
}
if(*iterations > 1) Rprintf("\n");
topmodel_memory_free(*nch, *ntimestep, *nidxclass);
return;
}
void processEvents()
{
#ifdef __APPLE__
R_ProcessEvents();
#else
// check for activity on standard input handlers (but ignore stdin).
// return immediately if there is no input currently available
fd_set* what = R_checkActivity(0,1);
// run handlers on the input (or run the polled event handler if there
// is no input currently available)
R_runHandlers(R_InputHandlers, what);
#endif
}
/*********************
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;
}
void rcall_process_events()
{
if (!R_is_ready) return;
R_is_ready = 0;
// FIXME: a dirty fix to prevent segfault right after a sigint
R_interrupts_pending = 0;
#ifdef __APPLE__
R_ProcessEvents();
#endif
fd_set* what = R_checkActivity(0,1);
if (what != NULL) R_runHandlers(R_InputHandlers, what);
R_is_ready = 1;
}
SEXP do_syssleep(SEXP call, SEXP op, SEXP args, SEXP rho)
{
DWORD mtime;
int ntime;
double time;
checkArity(op, args);
time = asReal(CAR(args));
if (ISNAN(time) || time < 0)
errorcall(call, _("invalid '%s' value"), "time");
ntime = 1000*(time) + 0.5;
while (ntime > 0) {
mtime = min(500, ntime);
ntime -= mtime;
Sleep(mtime);
R_ProcessEvents();
}
return R_NilValue;
}
SEXP menu_ttest3()
{
char cmd[256];
SEXP cmdSexp, cmdexpr, ans = R_NilValue;
int i;
ParseStatus status;
done = 0;
create_dialog();
setaction(bCancel, cancel2);
show(win);
for(;;) {
R_WaitEvent();
R_ProcessEvents();
if(done > 0) break;
}
if(done == 1) {
sprintf(cmd, "t.test(x=%s, y=%s, alternative=\"%s\",\n paired=%s, var.equal=%s, conf.level=%s)\n", v[0], v[1],
alts[getlistitem(alt)],
ischecked(paired) ? "TRUE" : "FALSE",
ischecked(varequal) ? "TRUE" : "FALSE",
GA_gettext(lvl));
}
hide(win);
delobj(bApply);
delobj(win);
if(done == 1) {
PROTECT(cmdSexp = allocVector(STRSXP, 1));
SET_STRING_ELT(cmdSexp, 0, mkChar(cmd));
cmdexpr = PROTECT(R_ParseVector(cmdSexp, -1, &status, R_NilValue));
if (status != PARSE_OK) {
UNPROTECT(2);
error("invalid call %s", cmd);
}
/* Loop is needed here as EXPSEXP will be of length > 1 */
for(i = 0; i < length(cmdexpr); i++)
ans = eval(VECTOR_ELT(cmdexpr, i), R_GlobalEnv);
UNPROTECT(2);
}
return ans;
}
/* just retrieve values from the dialog box and assemble call in
interpreted code
*/
void menu_ttest(char **vars, int ints[], double level[])
{
done = 0;
create_dialog();
setaction(bCancel, cancel);
show(win);
for(;;) {
R_WaitEvent();
R_ProcessEvents();
if(done > 0) break;
}
vars[0] = v[0]; vars[1] = v[1];
ints[0] = getlistitem(alt);
ints[1] = ischecked(paired);
ints[2] = ischecked(varequal);
ints[3] = done;
level[0] = R_atof(GA_gettext(lvl));
hide(win);
delobj(bApply);
delobj(win);
}
/*********************
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;
}
void
EmbeddedR_ProcessEvents()
{
if (! RINTERF_HASARGSSET()) {
printf("R should not process events before being initialized.");
return;
}
if (RINTERF_ISBUSY()) {
printf("Concurrent access to R is not allowed.");
return;
}
// setlock
RStatus = RStatus | RINTERF_ISBUSY();
#if defined(HAVE_AQUA) || (defined(Win32) || defined(Win64))
/* Can the call to R_ProcessEvents somehow fail ? */
R_ProcessEvents();
#endif
#if ! (defined(Win32) || defined(Win64))
R_runHandlers(R_InputHandlers, R_checkActivity(0, 1));
#endif
// freelock
RStatus = RStatus ^ RINTERF_ISBUSY();
}
/*********************
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 R_SockConnect(int port, char *host, int timeout)
{
SOCKET s;
fd_set wfd, rfd;
struct timeval tv;
int status = 0;
double used = 0.0;
struct sockaddr_in server;
struct hostent *hp;
check_init();
s = socket(PF_INET, SOCK_STREAM, IPPROTO_TCP);
if (s == -1) return -1;
#define CLOSE_N_RETURN(_ST_) { closesocket(s); return(_ST_); }
#ifdef Win32
{
u_long one = 1;
status = ioctlsocket(s, FIONBIO, &one) == SOCKET_ERROR ? -1 : 0;
}
#else
# ifdef HAVE_FCNTL
if ((status = fcntl(s, F_GETFL, 0)) != -1) {
# ifdef O_NONBLOCK
status |= O_NONBLOCK;
# else /* O_NONBLOCK */
# ifdef F_NDELAY
status |= F_NDELAY;
# endif
# endif /* !O_NONBLOCK */
status = fcntl(s, F_SETFL, status);
}
# endif // HAVE_FCNTL
if (status < 0) {
CLOSE_N_RETURN(-1);
}
#endif
if (! (hp = gethostbyname(host))) CLOSE_N_RETURN(-1);
memcpy((char *)&server.sin_addr, hp->h_addr_list[0], hp->h_length);
server.sin_port = htons((short)port);
server.sin_family = AF_INET;
if ((connect(s, (struct sockaddr *) &server, sizeof(server)) == -1)) {
switch (socket_errno()) {
case EINPROGRESS:
case EWOULDBLOCK:
break;
default:
CLOSE_N_RETURN(-1);
}
}
while(1) {
int maxfd = 0;
R_ProcessEvents();
#ifdef Unix
if(R_wait_usec > 0) {
R_PolledEvents();
tv.tv_sec = 0;
tv.tv_usec = R_wait_usec;
} else {
tv.tv_sec = timeout;
tv.tv_usec = 0;
}
#elif defined(Win32)
tv.tv_sec = 0;
tv.tv_usec = 2e5;
#else
tv.tv_sec = timeout;
tv.tv_usec = 0;
#endif
#ifdef Unix
maxfd = setSelectMask(R_InputHandlers, &rfd);
#else
FD_ZERO(&rfd);
#endif
FD_ZERO(&wfd);
FD_SET(s, &wfd);
if(maxfd < s) maxfd = s;
switch(R_SelectEx(maxfd+1, &rfd, &wfd, NULL, &tv, NULL))
{
case 0:
/* Time out */
used += tv.tv_sec + 1e-6 * tv.tv_usec;
if(used < timeout) continue;
CLOSE_N_RETURN(-1);
case -1:
/* Ermm.. ?? */
CLOSE_N_RETURN(-1);
}
if ( FD_ISSET(s, &wfd) ) {
R_SOCKLEN_T len;
len = sizeof(status);
if (getsockopt(s, SOL_SOCKET, SO_ERROR, (char*)&status, &len) < 0){
/* Solaris error code */
return (-1);
}
if ( status ) {
errno = status;
CLOSE_N_RETURN(-1);
} else return(s);
#ifdef Unix
} else { /* some other handler needed */
InputHandler *what;
what = getSelectedHandler(R_InputHandlers, &rfd);
if(what != NULL) what->handler((void*) NULL);
continue;
#endif
}
}
/* not reached
return(-1); */
}
/**** FIXME: add timeout argument instead of using global?? */
int R_SocketWaitMultiple(int nsock, int *insockfd, int *ready, int *write,
double mytimeout)
{
fd_set rfd, wfd;
struct timeval tv;
double used = 0.0;
int nready = 0;
while(1) {
int maxfd = 0, howmany, i;
R_ProcessEvents();
#ifdef Unix
if(R_wait_usec > 0) {
int delta;
if (mytimeout < 0 || R_wait_usec / 1e-6 < mytimeout - used)
delta = R_wait_usec;
else
delta = (int)ceil(1e6 * (mytimeout - used));
tv.tv_sec = 0;
tv.tv_usec = delta;
} else if (mytimeout >= 0) {
tv.tv_sec = (int)(mytimeout - used);
tv.tv_usec = (int)ceil(1e6 * (mytimeout - used - tv.tv_sec));
} else { /* always poll occationally--not really necessary */
tv.tv_sec = 60;
tv.tv_usec = 0;
}
#elif defined(Win32)
tv.tv_sec = 0;
tv.tv_usec = 2e5;
#else
if (mytimeout >= 0) {
tv.tv_sec = mytimeout - used;
tv.tv_usec = ceil(1e6 * (mytimeout - used - tv.tv_sec));
} else { /* always poll occasionally--not really necessary */
tv.tv_sec = timeout;
tv.tv_usec = 0;
}
#endif
#ifdef Unix
maxfd = setSelectMask(R_InputHandlers, &rfd);
#else
FD_ZERO(&rfd);
#endif
FD_ZERO(&wfd);
for (i = 0; i < nsock; i++) {
if(write[i]) FD_SET(insockfd[i], &wfd);
else FD_SET(insockfd[i], &rfd);
if(maxfd < insockfd[i]) maxfd = insockfd[i];
}
/* increment used value _before_ the select in case select
modifies tv (as Linux does) */
used += tv.tv_sec + 1e-6 * tv.tv_usec;
howmany = R_SelectEx(maxfd+1, &rfd, &wfd, NULL, &tv, NULL);
if (howmany < 0) {
return -socket_errno();
}
if (howmany == 0) {
if(mytimeout >= 0 && used >= mytimeout) {
for (i = 0; i < nsock; i++)
ready[i] = 0; /* FALSE */
return 0;
}
continue;
}
for (i = 0; i < nsock; i++)
if ((!write[i] && FD_ISSET(insockfd[i], &rfd)) ||
(write[i] && FD_ISSET(insockfd[i], &wfd))) {
ready[i] = 1; /* TRUE */
nready++;
}
else ready[i] = 0; /* FALSE */
#ifdef Unix
if(howmany > nready) {
/* one of the extras is ready */
InputHandler *what;
what = getSelectedHandler(R_InputHandlers, &rfd);
if(what != NULL) what->handler((void*) NULL);
continue;
}
#endif
/* some sockets are ready */
break;
}
return nready;
}
static int R_SocketWait(int sockfd, int write, int timeout)
{
fd_set rfd, wfd;
struct timeval tv;
double used = 0.0;
while(1) {
int maxfd = 0, howmany;
R_ProcessEvents();
#ifdef Unix
if(R_wait_usec > 0) {
tv.tv_sec = 0;
tv.tv_usec = R_wait_usec;
} else {
tv.tv_sec = timeout;
tv.tv_usec = 0;
}
#elif defined(Win32)
tv.tv_sec = 0;
tv.tv_usec = 2e5;
#else
tv.tv_sec = timeout;
tv.tv_usec = 0;
#endif
#ifdef Unix
maxfd = setSelectMask(R_InputHandlers, &rfd);
#else
FD_ZERO(&rfd);
#endif
FD_ZERO(&wfd);
if(write) FD_SET(sockfd, &wfd); else FD_SET(sockfd, &rfd);
if(maxfd < sockfd) maxfd = sockfd;
/* increment used value _before_ the select in case select
modifies tv (as Linux does) */
used += tv.tv_sec + 1e-6 * tv.tv_usec;
howmany = R_SelectEx(maxfd+1, &rfd, &wfd, NULL, &tv, NULL);
if (howmany < 0) {
return -socket_errno();
}
if (howmany == 0) {
if(used >= timeout) return 1;
continue;
}
#ifdef Unix
if((!write && !FD_ISSET(sockfd, &rfd)) ||
(write && !FD_ISSET(sockfd, &wfd)) || howmany > 1) {
/* was one of the extras */
InputHandler *what;
what = getSelectedHandler(R_InputHandlers, &rfd);
if(what != NULL) what->handler((void*) NULL);
continue;
}
#endif
/* the socket was ready */
break;
}
return 0;
}
/*
* 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 R_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) {
switch (R_YesNoCancel(G_("Save workspace image?"))) {
case YES:
saveact = SA_SAVE;
break;
case NO:
saveact = SA_NOSAVE;
break;
case CANCEL:
// There might be residual events with destroyed handles
R_ProcessEvents();
jump_to_toplevel();
break;
}
} else saveact = SaveAction;
}
switch (saveact) {
case SA_SAVE:
if(runLast) R_dot_Last();
if(R_DirtyImage) R_SaveGlobalEnv();
if (CharacterMode == RGui) {
R_setupHistory(); /* re-read the history size and filename */
wgl_savehistory(R_HistoryFile, R_HistorySize);
} else if(R_Interactive && CharacterMode == RTerm) {
R_setupHistory(); /* re-read the history size and filename */
gl_savehistory(R_HistoryFile, R_HistorySize);
}
break;
case SA_NOSAVE:
if(runLast) R_dot_Last();
break;
case SA_SUICIDE:
default:
break;
}
R_RunExitFinalizers();
editorcleanall();
CleanEd();
KillAllDevices(); /* Unix does not do this under SA_SUICIDE */
AllDevicesKilled = TRUE; /* used in devWindows.c to inhibit callbacks */
R_CleanTempDir(); /* changes directory */
if (R_Interactive && CharacterMode == RTerm)
SetConsoleTitle(oldtitle);
if (R_CollectWarnings && saveact != SA_SUICIDE
&& CharacterMode == RTerm) /* no point in doing this for Rgui
as the console is about to close */
PrintWarnings(); /* from device close and (if run) .Last */
app_cleanup();
RConsole = NULL;
if(ifp) fclose(ifp); /* input file from -f or --file= */
if(ifile[0]) unlink(ifile); /* input file from -e */
exit(status);
}
void processEvents()
{
R_ProcessEvents();
}
void visit(Visitor &visitor) const
{
// Visits unique trophic chains the network represented by adjancency.
DEBUG(Rprintf("DUMP GRAPH\n"));
DEBUG(print_adjacency());
bool queue_warning = false;
for(int n = 0; n < adjacency_.size(); ++n)
{
if(adjacency_[n].size() == 0) continue; // Node n has no out-edges, it
// cannot start a chain
if(is_basal_[n] == 0) continue; // Node n has in-edges, so it cannot
// start a chain
IntVector path(1, n);
DEBUG(print_path("INITIAL PATH", path));
Queue queue;
queue.push(path);
while(!queue.empty())
{
path = queue.front();
queue.pop();
R_ProcessEvents();
if(max_queue_>0 && !queue_warning && queue.size()>max_queue_/2)
{
REprintf("This network has a lot of paths, possibly too many to "
"compute\n");
queue_warning = true;
}
else if(max_queue_>0 && queue.size()>max_queue_)
{
throw CheddarException("Unable to compute paths - see the help for "
"TrophicChains for more information.");
}
int m = path.back();
DEBUG(Rprintf("AT NODE [%d]\n", m));
if(adjacency_[m].size() == 0)
{
DEBUG(print_path("", path));
visitor.chain(path);
}
else
{
bool cycle = true;
for(int j=0; j<adjacency_[m].size(); ++j)
{
bool found = false;
for(IntVector::const_iterator k=path.begin(); k!=path.end(); ++k)
{
if(*k == adjacency_[m][j])
{
found = true;
break;
}
}
if(!found)
{
path.push_back(adjacency_[m][j]);
DEBUG(print_path("EXTEND PATH", path));
queue.push(path);
path.pop_back();
cycle = false;
}
}
if(cycle)
{
DEBUG(print_path("", path));
visitor.chain(path);
}
}
}
}
}
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);
}
/* ML estimation of parameters in mixture model via EM;
*/
double QTLmixture(cmatrix loci, cvector cofactor, vector r, cvector position,
vector y, ivector ind, int Nind, int Naug,
int Nloci,
double *variance, int em, vector *weight,char REMLorML,char fitQTL,char dominance,char crosstype,Mmatrix MendelM,int verbose){
//if(verbose==1){Rprintf("QTLmixture called\n");}
int iem= 0, newNaug, i, j;
char varknown, biasadj='n';
double oldlogL=-10000, delta=1.0, calc_i, logP=0.0, Pscale=1.75;
double calc_ii;
vector indweight, Ploci, Fy;
indweight= newvector(Nind);
newNaug= (fitQTL=='n' ? Naug : 3*Naug);
Fy= newvector(newNaug);
logP= Nloci*log(Pscale); // only for computational accuracy
varknown= (((*variance)==-1.0) ? 'n' : 'y' );
Ploci= newvector(newNaug);
#ifndef ALONE
R_CheckUserInterrupt(); /* check for ^C */
R_ProcessEvents();
R_FlushConsole();
#endif
if ((REMLorML=='0')&&(varknown=='n')){
// Rprintf("INFO: REML\n");
}
if (REMLorML=='1') {
// Rprintf("INFO: ML\n");
varknown='n'; biasadj='n';
}
for (i=0; i<newNaug; i++){
Ploci[i]= 1.0;
}
if (fitQTL=='n'){
//Rprintf("FitQTL=N\n");
for (j=0; j<Nloci; j++){
for (i=0; i<Naug; i++)
Ploci[i]*= Pscale;
//Here we have ProbLeft
if ((position[j]=='L')||(position[j]=='U')){
for (i=0; i<Naug; i++){
calc_i= prob(loci,r,i,j,'1',crosstype,1,0,1);
//calc_ii= probnew(MendelM,loci,r,i,j,'1',crosstype,1,0,1);
Ploci[i]*= calc_i;
//Rprintf("DEBUG: Prob vs ProbNew: %f %f\n",calc_i,calc_ii);
}
}
if ((position[j]=='L')||(position[j]=='M')){
for (i=0; i<Naug; i++){
calc_i = prob(loci,r,i,j,loci[j+1][i],'F',0,0,0);
//calc_ii = probnew(MendelM,loci,r,i,j,loci[j+1][i],'F',0,0,0);
Ploci[i]*= calc_i;
//Rprintf("DEBUG: Prob vs ProbNew: %f %f\n",calc_i,calc_ii);
}
}
}
}else{
// Rprintf("FitQTL=Y\n");
for (j=0; j<Nloci; j++)
{ for (i=0; i<Naug; i++)
{ Ploci[i]*= Pscale; Ploci[i+Naug]*= Pscale; Ploci[i+2*Naug]*= Pscale;
// only for computational accuracy; see use of logP
}
if ((position[j]=='L')||(position[j]=='U'))
{
//Here we don't have any f2 dependancies anymore by using the prob function
if (cofactor[j]<='1')
for (i=0; i<Naug; i++)
{
calc_i= prob(loci,r,i,j,'1',crosstype,1,0,1);
//calc_ii= probnew(MendelM,loci,r,i,j,'1',crosstype,1,0,1);
Ploci[i]*= calc_i; Ploci[i+Naug]*= calc_i; Ploci[i+2*Naug]*= calc_i;
//Rprintf("DEBUG: Prob vs ProbNew: %f %f\n",calc_i,calc_ii);
}
else
for (i=0; i<Naug; i++)
{
//startvalues for each new chromosome
Ploci[i]*= start_prob(crosstype,'0');
Ploci[i+Naug]*= start_prob(crosstype,'1');
Ploci[i+2*Naug] *= start_prob(crosstype,'2');
}
// QTL='0', '1' or'2'
}
if ((position[j]=='L')||(position[j]=='M'))
{ if ((cofactor[j]<='1')&&(cofactor[j+1]<='1'))
for (i=0; i<Naug; i++){
calc_i = prob(loci,r,i,j,loci[j+1][i],crosstype,0,0,0);
//calc_ii = probnew(MendelM,loci,r,i,j,loci[j+1][i],crosstype,0,0,0);
Ploci[i]*= calc_i; Ploci[i+Naug]*= calc_i; Ploci[i+2*Naug]*= calc_i;
//Rprintf("DEBUG: Prob vs ProbNew: %f %f\n",calc_i,calc_ii);
}
else if (cofactor[j]<='1') // locus j+1 == QTL
for (i=0; i<Naug; i++)
{ // QTL=='0' What is the prob of finding an '0' at J=1
calc_i = prob(loci,r,i,j,'0',crosstype,1,0,0);
//calc_ii = probnew(MendelM,loci,r,i,j,'0',crosstype,1,0,0);
Ploci[i]*= calc_i;
// QTL=='1'
calc_i = prob(loci,r,i,j,'1',crosstype,1,0,0);
//calc_ii = probnew(MendelM,loci,r,i,j,'1',crosstype,1,0,0);
Ploci[i+Naug]*= calc_i;
// QTL=='2'
calc_i = prob(loci,r,i,j,'2',crosstype,1,0,0);
//calc_ii = probnew(MendelM,loci,r,i,j,'2',crosstype,1,0,0);
Ploci[i+2*Naug]*= calc_i;
//Rprintf("DEBUG: Prob vs ProbNew: %f %f\n",calc_i,calc_ii);
}
else // locus j == QTL
for (i=0; i<Naug; i++)
{ // QTL=='0'
calc_i = prob(loci,r,i,j+1,'0',crosstype,1,-1,0);
//calc_ii = probnew(MendelM,loci,r,i,j+1,'0',crosstype,1,-1,0);
Ploci[i]*= calc_i;
// QTL=='1'
calc_i = prob(loci,r,i,j+1,'1',crosstype,1,-1,0);
//calc_ii = probnew(MendelM,loci,r,i,j+1,'1',crosstype,1,-1,0);
Ploci[i+Naug]*= calc_i;
// QTL=='2'
calc_i = prob(loci,r,i,j+1,'2',crosstype,1,-1,0);
//calc_ii = probnew(MendelM,loci,r,i,j+1,'2',crosstype,1,-1,0);
Ploci[i+2*Naug]*= calc_i;
//Rprintf("DEBUG: Prob vs ProbNew: %f %f\n",calc_i,calc_ii);
}
}
}
}
// Rprintf("INFO: Done fitting QTL's\n");
if ((*weight)[0]== -1.0)
{ for (i=0; i<Nind; i++) indweight[i]= 0.0;
if (fitQTL=='n')
{ 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]];
}
}
}
//Rprintf("Weights done\n");
//Rprintf("Individual->trait->cofactor->weight\n");
//for (int j=0; j<Nind; j++){
// Rprintf("%d->%f,%d,%f %f\n",j,y[j],cofactor[j],(*weight)[j],Ploci[j]);
//}
double logL=0;
vector indL;
indL= newvector(Nind);
while ((iem<em)&&(delta>1.0e-5))
{
iem+=1;
if (varknown=='n') *variance=-1.0;
//Rprintf("Checkpoint_b\n");
logL= regression(Nind, Nloci, cofactor, loci, y,
weight, ind, Naug, variance, Fy, biasadj,fitQTL,dominance);
logL=0.0;
//Rprintf("regression ready\n");
for (i=0; i<Nind; i++) indL[i]= 0.0;
if (fitQTL=='n') // 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=='n')
{ 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= absdouble(logL-oldlogL);
oldlogL= logL;
}
//Rprintf("EM Finished\n");
// bias adjustment after finished ML estimation via EM
if ((REMLorML=='0')&&(varknown=='n'))
{
// RRprintf("Checkpoint_c\n");
*variance=-1.0;
biasadj='y';
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=='n')
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=='n')
{ 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++){
// Rprintf("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;
}
/*********************
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 R_WriteConsoleEx(const char *buf, int len, int otype)
{
R_ProcessEvents();
if (TrueWriteConsole) TrueWriteConsole(buf, len);
else TrueWriteConsoleEx(buf, len, otype);
}
void R_WriteConsole(char *buf, int len)
{
R_ProcessEvents();
TrueWriteConsole(buf, len);
}
/*********************
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 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;
}