Beispiel #1
0
/* 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);
}
Beispiel #2
0
 /* 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);
}
Beispiel #3
0
Datei: run.c Projekt: kmillar/rho
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.. */
}
Beispiel #4
0
static void eventloop(editor c)
{
    while (fix_editor_up) {
	/* avoid consuming 100% CPU time here */
	Sleep(10);
	R_ProcessEvents();
    }
}
Beispiel #5
0
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]);
    }
}
Beispiel #6
0
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;
}
Beispiel #7
0
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
}
Beispiel #8
0
Datei: wtCD.c Projekt: Zsedo/ergm
/*********************
 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;
}
Beispiel #9
0
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;
}
Beispiel #10
0
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;
}
Beispiel #11
0
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;
}
Beispiel #12
0
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;
}
Beispiel #13
0
/* 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);
}
Beispiel #14
0
/*********************
 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();
}
Beispiel #16
0
Datei: MCMC.c Projekt: Zsedo/ergm
/*********************
 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);
}
Beispiel #17
0
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); */
}
Beispiel #18
0
/**** 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;
}
Beispiel #19
0
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;
}
Beispiel #20
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;
			}
		}
    }
}
Beispiel #21
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);
}
Beispiel #22
0
void processEvents()
{
   R_ProcessEvents();
}
Beispiel #23
0
 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);
}
Beispiel #25
0
/* 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;
}
Beispiel #26
0
Datei: MCMC.c Projekt: Zsedo/ergm
/*********************
 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;
}
Beispiel #27
0
void R_WriteConsoleEx(const char *buf, int len, int otype)
{
    R_ProcessEvents();
    if (TrueWriteConsole) TrueWriteConsole(buf, len);
    else TrueWriteConsoleEx(buf, len, otype);
}
Beispiel #28
0
void R_WriteConsole(char *buf, int len)
{
    R_ProcessEvents();
    TrueWriteConsole(buf, len);
}
Beispiel #29
0
/*********************
 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;
}
Beispiel #30
0
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;
    
    
}