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; }
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); }