Exemplo n.º 1
0
SEXP rgbern_R(SEXP sn, SEXP stp, SEXP sdirected, SEXP sloops, SEXP spmode)
/*
Draw a Bernoulli graph using the algorithm of Batagelj and Brandes (2005), with minor modifications to allow for directed/undirected graphs, loops, and row/column heterogeneity.  The Bernoulli parameters are contained in stp, as either a vector or single value (as appropriate, given the mode).  spmode indicates the type of heterogeneity to employ:
  0 (BERNHOM) - Homogeneous
  1 (BERNROW) - Row-heterogeneous
  2 (BERNCOL) - Column heterogeneous
  3 (BERNHET) - Heterogeneous  (the brute force method is used here)
The resulting graph is returned as an sna edgelist, complete with "n" attribute.  Multiple calls to this function may be used to obtain multiple graphs.  Note
*/
{
  int i,j,n,m,directed,loops,pmode,pc=0;
  double *tp,*g,r,c,en,w;
  element *el,*ep;
  SEXP sg,sn2,dim;
  
  /*Initalize stuff*/
  PROTECT(sn=coerceVector(sn,INTSXP)); pc++;
  PROTECT(stp=coerceVector(stp,REALSXP)); pc++;
  PROTECT(sdirected=coerceVector(sdirected,INTSXP)); pc++;
  PROTECT(sloops=coerceVector(sloops,INTSXP)); pc++;
  PROTECT(spmode=coerceVector(spmode,INTSXP)); pc++;
  n=INTEGER(sn)[0];
  tp=REAL(stp);
  directed=INTEGER(sdirected)[0];
  loops=INTEGER(sloops)[0];
  pmode=INTEGER(spmode)[0];
  GetRNGstate();
  m=0;
  el=NULL;
    
  /*Generate the graph, using the appropriate mode*/
  switch(pmode){
    case BERNHOM:  /*For each row, use a waiting time scheme*/
      if(directed)            /*Get maximum number of edges*/
        en=(double)(n*(n-1.0));
      else
        en=(double)(n*(n-1.0)/2.0);
      en+=(double)(loops*n);
      w=-1.0;                 /*Draw edges*/
      while(w<en){
        w+=1.0+rgeom(tp[0]);
        if(w<en){
          if(directed){
            if(loops){
              r=fmod(w,(double)n);
              c=floor(w/(double)n);
            }else{
              c=floor(w/(n-1.0));
              r=fmod(w,n-1.0)+(fmod(w,n-1.0)>=c);
            }
          }else{
            if(loops){
              c=n-floor(sqrt(n*(n+1.0)-2.0*w-1.75)-0.5)-1.0;
              r=w-c*(n-1.0)+c*(c-1.0)/2.0;
            }else{
              c=n-2.0-floor(sqrt(n*(n-1.0)-2.0*w-1.75)-0.5);
              r=w+c*((c+1.0)/2.0-n+1.0)+1.0;
            }
          }
          el=enqueue(el,r+c*n,NULL);
          m++;
          if((!directed)&&(r!=c)){
            el=enqueue(el,c+r*n,NULL);
            m++;
          }
        }
      }
      break;
    case BERNROW:  /*For each row, use a waiting time scheme*/
      for(i=0;i<n;i++){    /*Walk through the rows*/
        if(directed)            /*Get maximum number of edges*/
          en=(double)(n-1.0);
        else
          en=(double)i;
        en+=loops;
        w=-1.0;                 /*Draw edges*/
        while(w<en){
          w+=1.0+rgeom(tp[i]);
          if(w<en){
            el=enqueue(el,i+(w+(!loops)*(w>=(double)i))*n,NULL);
            m++;
            if((!directed)&&((!loops)||(w!=(double)i))){
              el=enqueue(el,(w+(!loops)*(w>=(double)i))+i*n,NULL);
              m++;
            }
          }
        }
      }
      break;
    case BERNCOL:
      for(i=0;i<n;i++){    /*Walk through the cols*/
        if(directed)            /*Get maximum number of edges*/
          en=(double)(n-1.0);
        else
          en=(double)i;
        en+=loops;
        w=-1.0;                 /*Draw edges*/
        while(w<en){
          w+=1.0+rgeom(tp[i]);
          if(w<en){
            el=enqueue(el,(w+(!loops)*(w>=(double)i))+i*n,NULL);
            m++;
            if((!directed)&&((!loops)||(w!=(double)i))){
              el=enqueue(el,i+(w+(!loops)*(w>=(double)i))*n,NULL);
              m++;
            }
          }
        }
      }
      break;
    case BERNHET:  /*No shortcuts, just draw directly*/
      for(i=0;i<n;i++)
        for(j=i*(!directed);j<n;j++)
          if(loops||(i!=j))
            if(runif(0.0,1.0)<tp[i+j*n]){
              el=enqueue(el,(double)(i+j*n),NULL);
              m++;
              if((!directed)&&(i!=j)){
                el=enqueue(el,(double)(j+i*n),NULL);
                m++;
              }
            }
      break;
  }
  
  /*Store the result*/
  PROTECT(sg=allocVector(REALSXP,3*m)); pc++;
  g=REAL(sg);
  for(i=0,ep=el;ep!=NULL;ep=ep->next){
    c=floor((ep->val)/(double)n);
    r=fmod(ep->val,(double)n);
    g[i]=r+1;
    g[i+m]=c+1;
    g[i+2*m]=1.0;
    i++;
  }
  PROTECT(sn2=allocVector(INTSXP,1)); pc++;  /*Set graph size attribute*/
  INTEGER(sn2)[0]=n;
  setAttrib(sg,install("n"), sn2);
  PROTECT(dim=allocVector(INTSXP, 2)); pc++; /*Set dimension attribute*/
  INTEGER(dim)[0] = m; 
  INTEGER(dim)[1] = 3;
  setAttrib(sg,R_DimSymbol,dim);

  /*Unprotect and return*/
  PutRNGstate();
  UNPROTECT(pc);
  return sg;
}
Exemplo n.º 2
0
SEXP predkda(SEXP s_test, SEXP s_learn, SEXP s_grouping, SEXP s_wf, SEXP s_bw, SEXP s_k, SEXP s_env)
{
	const R_len_t p = ncols(s_test);			// dimensionality
	R_len_t N_learn = nrows(s_learn);		// # training observations
	const R_len_t N_test = nrows(s_test);		// # test observations
	const R_len_t K = nlevels(s_grouping);		// # classes
	double *test = REAL(s_test);				// pointer to test data set
	double *learn = REAL(s_learn);				// pointer to training data set
	int *g = INTEGER(s_grouping);				// pointer to class labels
	int *k = INTEGER(s_k);						// pointer to number of nearest neighbors
	double *bw = REAL(s_bw);					// bandwidth
	/*Rprintf("k %u\n", *k);
	Rprintf("bw %f\n", *bw);
	 */
	
	
	SEXP s_posterior;							// initialize posteriors
	PROTECT(s_posterior = allocMatrix(REALSXP, N_test, K));
	double *posterior = REAL(s_posterior);
	
	SEXP s_dist;								// initialize distances to test observation
	PROTECT(s_dist = allocVector(REALSXP, N_learn));
	double *dist = REAL(s_dist);
	
	SEXP s_weights;								// initialize weight vector
	PROTECT(s_weights = allocVector(REALSXP, N_learn));
	double *weights = REAL(s_weights);
	
	int nas = 0;
	
	int i, j, l, n;								// indices
		
	// select weight function
	typedef void (*wf_ptr_t) (double*, double*, int*, double*, int*);// *weights, *dist, *N, *bw, *k
	wf_ptr_t wf = NULL;
	if (isInteger(s_wf)) {
		const int wf_nr = INTEGER(s_wf)[0];
		//Rprintf("wf_nr %u\n", wf_nr);
		wf_ptr_t wfs[] = {biweight1, cauchy1, cosine1, epanechnikov1, exponential1, gaussian1,
			optcosine1, rectangular1, triangular1, biweight2, cauchy2, cosine2, epanechnikov2,
			exponential2, gaussian2, optcosine2, rectangular2, triangular2, biweight3, cauchy3,
			cosine3, epanechnikov3, exponential3, gaussian3, optcosine3, rectangular3, 
			triangular3, cauchy4, exponential4, gaussian4};
		wf = wfs[wf_nr - 1];
	}
	
	// loop over all test observations
	for(n = 0; n < N_test; n++) {
			
		// 0. check for NAs in test
		nas = 0;
		for (j = 0; j < p; j++) {
			nas += ISNA(test[n + N_test * j]);
		}
		if (nas > 0) { // NAs in n-th test observation
			warning("NAs in test observation %u", n+1);
			// set posterior to NA
			for (l = 0; l < K; l++) {
				posterior[n + N_test * l] = NA_REAL;
			}			
		} else {
			// 1. calculate distances to n-th test observation
			for (i = 0; i < N_learn; i++) {
				dist[i] = 0;
				for (j = 0; j < p; j++) {
					dist[i] += pow(learn[i + N_learn * j] - test[n + N_test * j], 2);
				}
				dist[i] = sqrt(dist[i]);
				weights[i] = 0;				// important because some weights are 0
				//Rprintf("dist %f\n", dist[i]);
			}
				
			// 2. calculate observation weights
			if (isInteger(s_wf)) {
				// case 1: wf is integer
				// calculate weights by reading number and calling corresponding C function
				wf(weights, dist, &N_learn, bw, k);
			} else if (isFunction(s_wf)) {
				// case 2: wf is R function
				// calculate weights by calling R function
				SEXP R_fcall;
				PROTECT(R_fcall = lang2(s_wf, R_NilValue)); //R_NilValue = NULL??? NILSXP = NULL
				SETCADR(R_fcall, s_dist); // SETCADR: cadr list = (car (cdr list))
				weights = REAL(eval(R_fcall, s_env));
				UNPROTECT(1);	// R_fcall
			}
			/*for(i = 0; i < N_learn; i++) {
				Rprintf("weights %f\n", weights[i]);
			}*/
				
			// 3. calculate posterior probabilities as class wise sum of weights
			for (l = 0; l < K; l++) {
				posterior[n + N_test * l] = 0;
				for (i = 0; i < N_learn; i++) {
					if (g[i] == l + 1) {
						posterior[n + N_test * l] += weights[i];
					}
				}
			}
		}
			
	}
	// end loop over test observations
		
	// 4. set dimnames of s_posterior
	SEXP dimnames;
	PROTECT(dimnames = allocVector(VECSXP, 2));
	SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(getAttrib(s_test, R_DimNamesSymbol), 0));
	SET_VECTOR_ELT(dimnames, 1, getAttrib(s_grouping, R_LevelsSymbol));
	setAttrib(s_posterior, R_DimNamesSymbol, dimnames);
	
	//void R_max_col (double* matrix, int* nr, int* nc, int* maxes)
	// maxes initialisieren
	//R_max_col (posterior, &N_test, &K, int* maxes)
	
	UNPROTECT(4);	// dimnames, s_dist, s_weights, s_posterior
	return(s_posterior);
	
}