SEXP multifit_cor(SEXP par, SEXP Thalf, SEXP x, SEXP y, SEXP err, SEXP tr,
SEXP prec, SEXP N, SEXP max_iter, SEXP no_masses)
{
int npar, nx, ny, i, iter_max;
double p1, p2, m;
double *yp, *errp, *parp, *precp, *statep;
double chi_square, red_chi_square;
int dof;
int * xp, *Thalfp, *trp, *Np, *mip, *nmp;
SEXP state;
const gsl_multifit_fdfsolver_type *solver_type =
gsl_multifit_fdfsolver_lmsder;
/* Allocate the solver. */
gsl_multifit_fdfsolver *solver;
/* Initialize the data structure. */
struct data data_struct;
gsl_multifit_function_fdf function_fdf;
gsl_matrix *covar;
double * para_initial, c=1.;
gsl_vector_view para_initial_;
int status, iter=0, no_points=0;
PROTECT(par = AS_NUMERIC(par));
PROTECT(Thalf = AS_INTEGER(Thalf));
PROTECT(x = AS_INTEGER(x));
PROTECT(y = AS_NUMERIC(y));
PROTECT(err = AS_NUMERIC(err));
PROTECT(tr = AS_INTEGER(tr));
PROTECT(prec = AS_NUMERIC(prec));
PROTECT(N = AS_INTEGER(N));
PROTECT(max_iter = AS_INTEGER(max_iter));
PROTECT(no_masses = AS_INTEGER(no_masses));
xp = INTEGER_POINTER(x);
Thalfp = INTEGER_POINTER(Thalf);
trp = INTEGER_POINTER(tr);
Np = INTEGER_POINTER(N);
yp = NUMERIC_POINTER(y);
errp = NUMERIC_POINTER(err);
parp = NUMERIC_POINTER(par);
precp = NUMERIC_POINTER(prec);
mip = INTEGER_POINTER(max_iter);
nmp = INTEGER_POINTER(no_masses);
iter_max = mip[0];
npar = LENGTH(par);
nx = LENGTH(x);
ny = LENGTH(y);
assert(npar == nmp[0]*(Np[0]+1));
PROTECT(state = NEW_NUMERIC(5+npar));
statep = NUMERIC_POINTER(state);
/* PROTECT(gradient = allocMatrix(REALSXP, npar, npar)); */
if(Np[0] == 2) no_points = 3*trp[0];
if(Np[0] == 4) no_points = 10*trp[0];
if(Np[0] == 6) no_points = 21*trp[0];
solver = gsl_multifit_fdfsolver_alloc(solver_type, ny, npar);
data_struct.x = (double*) malloc(nx*sizeof(double));
data_struct.y = (double*) malloc(ny*sizeof(double));
data_struct.err = (double*) malloc(ny*sizeof(double));
para_initial = (double*) malloc(npar*sizeof(double));
for(i = 0; i < nx; i++) {
data_struct.x[i] = (double)xp[i];
}
for(i = 0; i < ny; i++) {
data_struct.y[i] = yp[i];
data_struct.err[i] = errp[i];
}
data_struct.Thalf = Thalfp[0];
data_struct.tr = trp[0];
data_struct.N = Np[0];
data_struct.no_masses = nmp[0];
// The ansatz.
function_fdf.f = &exp_f;
function_fdf.df = &exp_df;
function_fdf.fdf = &exp_fdf;
function_fdf.n = ny;
function_fdf.p = npar;
function_fdf.params = &data_struct;
for(i = 0; i < npar; i++) {
para_initial[i] = parp[i];
}
para_initial_ = gsl_vector_view_array(para_initial, npar);
gsl_multifit_fdfsolver_set(solver, &function_fdf, ¶_initial_.vector);
// Perform the fit.
// Print the initial state.
#ifdef _DEBUG
Print_State_Mass_Fit_Helper_1(iter, solver);
#endif
do {
iter++;
/* Do a solver iteration. */
status = gsl_multifit_fdfsolver_iterate(solver);
#ifdef _DEBUG
fprintf(stderr, "status = %s.\n", gsl_strerror(status));
Print_State_Mass_Fit_Helper_1(iter, solver);
#endif
if(status) {
break;
}
status = gsl_multifit_test_delta(solver->dx, solver->x,
precp[0], precp[1]);
}
while(status == GSL_CONTINUE && iter < iter_max);
#ifdef _DEBUG
fprintf(stderr, "\n");
#endif
// *****
// Compute the covariance matrix.
covar = gsl_matrix_alloc(npar, npar);
gsl_multifit_covar(solver->J, 0.0, covar);
// Output.
chi_square = pow(gsl_blas_dnrm2(solver->f), 2.0);
#ifdef _DEBUG
fprintf(stderr, "chi_square = %13.6lf.\n", chi_square);
#endif
dof = no_points - npar;
#ifdef _DEBUG
fprintf(stderr, "dof = %d\n", dof);
#endif
red_chi_square = chi_square / (double)dof;
#ifdef _DEBUG
fprintf(stderr, "red_chi_square = %13.6lf.\n", red_chi_square);
fprintf(stderr, "\n");
#endif
p1 = gsl_vector_get(solver->x, 0);
p2 = gsl_vector_get(solver->x, 1);
m = gsl_vector_get(solver->x, npar-1);
if(red_chi_square > 1.0)
c = sqrt(red_chi_square);
#ifdef _DEBUG
fprintf(stderr, "p1 = %+9.6lf +/- %9.6lf.\n",
p1, c * sqrt(gsl_matrix_get(covar, 0, 0)));
fprintf(stderr, "p2 = %+9.6lf +/- %9.6lf.\n",
p2, c * sqrt(gsl_matrix_get(covar, 1, 1)));
fprintf(stderr, "m = %+9.6lf +/- %9.6lf.\n",
m, c * sqrt(gsl_matrix_get(covar, npar-1, npar-1)));
fprintf(stderr, "\n");
fprintf(stderr, "status = %s.\n", gsl_strerror(status));
fprintf(stderr, "\n");
#endif
for(i = 0; i < npar; i++) {
statep[5+i] = gsl_vector_get(solver->x, i);
}
statep[0] = chi_square;
statep[1] = gsl_blas_dnrm2(solver->f);
statep[2] = (double)iter;
statep[3] = (double)dof;
statep[4] = (double)status;
gsl_multifit_fdfsolver_free(solver);
#ifdef _DEBUG
gsl_matrix_free(covar);
#endif
free(data_struct.x);
free(data_struct.y);
free(data_struct.err);
free(para_initial);
UNPROTECT(11);
return(state);
}
SEXP poly_loop2(SEXP n, SEXP i_findInBox, SEXP bb, SEXP pl, SEXP nrs,
SEXP dsnap, SEXP criterion, SEXP nfIBB) {
int nn = INTEGER_POINTER(n)[0];
int crit = INTEGER_POINTER(criterion)[0];
/* int Scale = INTEGER_POINTER(scale)[0];*/
int uBound = (int) INTEGER_POINTER(nfIBB)[0]*2;
int i, j, jj, li, pc = 0;
int ii = 0;
int *card, *icard, *is, *jjs, *NRS, *cNRS;
double *bb1, *bb2, *bb3, *bb4, *plx, *ply;
double Dsnap = NUMERIC_POINTER(dsnap)[0];
// struct bbcontainer *bbs;
SEXP ans;
int jhit, khit, nrsi, nrsj;
int xx, yy, zz, ww;
card = (int *) R_alloc((size_t) nn, sizeof(int));
icard = (int *) R_alloc((size_t) nn, sizeof(int));
is = (int *) R_alloc((size_t) uBound, sizeof(int));
jjs = (int *) R_alloc((size_t) uBound, sizeof(int));
bb1 = (double *) R_alloc((size_t) nn, sizeof(double));
bb2 = (double *) R_alloc((size_t) nn, sizeof(double));
bb3 = (double *) R_alloc((size_t) nn, sizeof(double));
bb4 = (double *) R_alloc((size_t) nn, sizeof(double));
NRS = (int *) R_alloc((size_t) nn, sizeof(int));
cNRS = (int *) R_alloc((size_t) nn, sizeof(int));
for (i=0, li=0; i<nn; i++) {
card[i] = 0;
icard[i] = 0;
bb1[i] = NUMERIC_POINTER(bb)[i];
bb2[i] = NUMERIC_POINTER(bb)[i+(1*nn)];
bb3[i] = NUMERIC_POINTER(bb)[i+(2*nn)];
bb4[i] = NUMERIC_POINTER(bb)[i+(3*nn)];
NRS[i] = INTEGER_POINTER(nrs)[i];
li += NRS[i];
}
for (i=0; i<nn; i++) {
if (i == 0) cNRS[i] = 0;
else cNRS[i] = NRS[i-1] + cNRS[i-1];
}
for (i=0; i<uBound; i++) {
is[i] = 0;
jjs[i] = 0;
}
plx = (double *) R_alloc((size_t) li, sizeof(double));
ply = (double *) R_alloc((size_t) li, sizeof(double));
for (i=0, jj=0; i<nn; i++) {
nrsi = NRS[i];
for (j=0; j<nrsi; j++) {
plx[jj] = NUMERIC_POINTER(VECTOR_ELT(pl, i))[j];
ply[jj] = NUMERIC_POINTER(VECTOR_ELT(pl, i))[j+nrsi];
jj++;
/* if (i < (nn-1) && jj == li) error("polygon memory overflow");*/
}
}
for (i=0; i<(nn-1); i++) {
li = length(VECTOR_ELT(i_findInBox, i));
nrsi = NRS[i];
for (j=0; j<li; j++) {
jj = INTEGER_POINTER(VECTOR_ELT(i_findInBox, i))[j] - ROFFSET;
jhit = spOverlapC(bb1[i], bb2[i], bb3[i], bb4[i], bb1[jj],
bb2[jj], bb3[jj], bb4[jj]);
if (jhit > 0) {
khit = 0;
nrsj = NRS[jj];
if (nrsi > 0 && nrsj > 0){
khit = polypolyC(&plx[cNRS[i]], &ply[cNRS[i]], nrsi,
&plx[cNRS[jj]], &ply[cNRS[jj]], nrsj, Dsnap, crit+1L);
}
if (khit > crit) {
card[i]++;
card[jj]++;
is[ii] = i;
jjs[ii] = jj;
ii++;
/* if (ii == uBound) error("memory error, scale problem");*/
}
}
}
}
PROTECT(ans = NEW_LIST(nn)); pc++;
for (i=0; i<nn; i++) {
if (card[i] == 0) {
SET_VECTOR_ELT(ans, i, NEW_INTEGER(1));
INTEGER_POINTER(VECTOR_ELT(ans, i))[0] = 0;
} else {
SET_VECTOR_ELT(ans, i, NEW_INTEGER(card[i]));
}
}
for (i=0; i<ii; i++) {
xx = is[i];
yy = jjs[i];
zz = icard[yy];
ww = icard[xx];
/* if (zz == card[yy]) error("memory error, overflow");
if (ww == card[xx]) error("memory error, overflow");*/
INTEGER_POINTER(VECTOR_ELT(ans, yy))[zz] = xx + ROFFSET;
INTEGER_POINTER(VECTOR_ELT(ans, xx))[ww] = yy + ROFFSET;
icard[yy]++;
icard[xx]++;
}
for (i=0; i<nn; i++) {
if ((li = length(VECTOR_ELT(ans, i))) > 1) {
for (j=0; j<li; j++)
icard[j] = INTEGER_POINTER(VECTOR_ELT(ans, i))[j];
R_isort(icard, li);
for (j=0; j<li; j++)
INTEGER_POINTER(VECTOR_ELT(ans, i))[j] = icard[j];
}
}
UNPROTECT(pc);
return(ans);
}
SEXP Muste_Editor(SEXP session)
{
extern int muste_window_existing;
extern int muste_eventtime;
extern int muste_eventtype;
extern long tutalku;
extern int tut_special_code;
extern int tut_not_break;
extern int sukro_esto;
extern int tut_not_break2;
extern int help_on;
extern int rajoitettu_vastausaika;
extern int sucro_menu;
extern int etu;
extern int tut_index;
extern int ntut;
extern int fixed_plot;
extern int first_plot_number;
extern int gplot_count;
extern int max_hdl;
extern int muste_expand;
extern int muste_GetTickCount_start();
// char argument[256];
int i;
SEXP ans=R_NilValue;
int *x;
muste_eventpeek=TRUE;
muste_eventlooprunning=FALSE;
muste_window_existing=FALSE;
muste_eventtime=0;
muste_eventtype=0;
tutalku=0L; /* 10.2.90 */
tut_special_code=0;
tut_not_break=0;
sukro_esto=0;
tut_not_break2=0;
help_on=0;
rajoitettu_vastausaika=0;
sucro_menu=0;
etu=0;
tut_index=0;
ntut=0;
muste_expand=0;
muste_emergency_stop=0;
muste_debug=0;
fixed_plot=0;
first_plot_number=1;
gplot_count=0;
max_hdl=MAX_HDL;
muste_init_plotwindows();
muste_GetTickCount_start(1);
// strcpy(argument,CHAR(STRING_ELT(session,0)));
muste_environment=session;
muste_eventpeek=FALSE;
muste_eventlooprunning=TRUE;
i=muste_editor("Muste"); // RS CHA argument);
PROTECT(ans = NEW_INTEGER(1));
x=INTEGER_POINTER(ans);
x[0]=i;
UNPROTECT(1);
muste_eventlooprunning=FALSE;
muste_eventpeek=TRUE;
return(ans);
}
void gibbsOneWayAnova(double *y, int *N, int J, int sumN, int *whichJ, double rscale, int iterations, double *chains, double *CMDE, SEXP debug, int progress, SEXP pBar, SEXP rho)
{
int i=0,j=0,m=0,Jp1sq = (J+1)*(J+1),Jsq=J*J,Jp1=J+1,npars=0;
double ySum[J],yBar[J],sumy2[J],densDelta=0;
double sig2=1,g=1;
double XtX[Jp1sq], ZtZ[Jsq];
double Btemp[Jp1sq],B2temp[Jsq],tempBetaSq=0;
double muTemp[J],oneOverSig2temp=0;
double beta[J+1],grandSum=0,grandSumSq=0;
double shapeSig2 = (sumN+J*1.0)/2, shapeg = (J+1.0)/2;
double scaleSig2=0, scaleg=0;
double Xty[J+1],Zty[J];
double logDet=0;
double rscaleSq=rscale*rscale;
double logSumSingle=0,logSumDouble=0;
// for Kahan sum
double kahanSumSingle=0, kahanSumDouble=0;
double kahanCSingle=0,kahanCDouble=0;
double kahanTempT=0, kahanTempY=0;
int iOne=1, info;
double dZero=0;
// progress stuff
SEXP sampCounter, R_fcall;
int *pSampCounter;
PROTECT(R_fcall = lang2(pBar, R_NilValue));
PROTECT(sampCounter = NEW_INTEGER(1));
pSampCounter = INTEGER_POINTER(sampCounter);
npars=J+5;
GetRNGstate();
// Initialize to 0
AZERO(XtX,Jp1sq);
AZERO(ZtZ,Jsq);
AZERO(beta,Jp1);
AZERO(ySum,J);
AZERO(sumy2,J);
// Create vectors
for(i=0;i<sumN;i++)
{
j = whichJ[i];
ySum[j] += y[i];
sumy2[j] += y[i]*y[i];
grandSum += y[i];
grandSumSq += y[i]*y[i];
}
// create design matrices
XtX[0]=sumN;
for(j=0;j<J;j++)
{
XtX[j+1]=N[j];
XtX[(J+1)*(j+1)]=N[j];
XtX[(j+1)*(J+1) + (j+1)] = N[j];
ZtZ[j*J + j] = N[j];
yBar[j] = ySum[j]/(1.0*N[j]);
}
Xty[0] = grandSum;
Memcpy(Xty+1,ySum,J);
Memcpy(Zty,ySum,J);
// start MCMC
for(m=0; m<iterations; m++)
{
R_CheckUserInterrupt();
//Check progress
if(progress && !((m+1)%progress)){
pSampCounter[0]=m+1;
SETCADR(R_fcall, sampCounter);
eval(R_fcall, rho); //Update the progress bar
}
// sample beta
Memcpy(Btemp,XtX,Jp1sq);
for(j=0;j<J;j++){
Btemp[(j+1)*(J+1)+(j+1)] += 1/g;
}
InvMatrixUpper(Btemp, J+1);
internal_symmetrize(Btemp,J+1);
for(j=0;j<Jp1sq;j++)
Btemp[j] *= sig2;
oneOverSig2temp = 1/sig2;
F77_CALL(dsymv)("U", &Jp1, &oneOverSig2temp, Btemp, &Jp1, Xty, &iOne, &dZero, beta, &iOne);
rmvGaussianC(beta, Btemp, J+1);
Memcpy(&chains[npars*m],beta,J+1);
// calculate density (Single Standardized)
Memcpy(B2temp,ZtZ,Jsq);
densDelta = -J*0.5*log(2*M_PI);
for(j=0;j<J;j++)
{
B2temp[j*J+j] += 1/g;
muTemp[j] = (ySum[j]-N[j]*beta[0])/sqrt(sig2);
}
InvMatrixUpper(B2temp, J);
internal_symmetrize(B2temp,J);
logDet = matrixDet(B2temp,J,J,1, &info);
densDelta += -0.5*quadform(muTemp, B2temp, J, 1, J);
densDelta += -0.5*logDet;
if(m==0){
logSumSingle = densDelta;
kahanSumSingle = exp(densDelta);
}else{
logSumSingle = logSumSingle + LogOnePlusX(exp(densDelta-logSumSingle));
kahanTempY = exp(densDelta) - kahanCSingle;
kahanTempT = kahanSumSingle + kahanTempY;
kahanCSingle = (kahanTempT - kahanSumSingle) - kahanTempY;
kahanSumSingle = kahanTempT;
}
chains[npars*m + (J+1) + 0] = densDelta;
// calculate density (Double Standardized)
densDelta += 0.5*J*log(g);
if(m==0){
logSumDouble = densDelta;
kahanSumDouble = exp(densDelta);
}else{
logSumDouble = logSumDouble + LogOnePlusX(exp(densDelta-logSumDouble));
kahanTempY = exp(densDelta) - kahanCDouble;
kahanTempT = kahanSumDouble + kahanTempY;
kahanCDouble = (kahanTempT - kahanSumDouble) - kahanTempY;
kahanSumDouble = kahanTempT;
}
chains[npars*m + (J+1) + 1] = densDelta;
// sample sig2
tempBetaSq = 0;
scaleSig2 = grandSumSq - 2*beta[0]*grandSum + beta[0]*beta[0]*sumN;
for(j=0;j<J;j++)
{
scaleSig2 += -2.0*(yBar[j]-beta[0])*N[j]*beta[j+1] + (N[j]+1/g)*beta[j+1]*beta[j+1];
tempBetaSq += beta[j+1]*beta[j+1];
}
scaleSig2 *= 0.5;
sig2 = 1/rgamma(shapeSig2,1/scaleSig2);
chains[npars*m + (J+1) + 2] = sig2;
// sample g
scaleg = 0.5*(tempBetaSq/sig2 + rscaleSq);
g = 1/rgamma(shapeg,1/scaleg);
chains[npars*m + (J+1) + 3] = g;
}
CMDE[0] = logSumSingle - log(iterations);
CMDE[1] = logSumDouble - log(iterations);
CMDE[2] = log(kahanSumSingle) - log(iterations);
CMDE[3] = log(kahanSumDouble) - log(iterations);
UNPROTECT(2);
PutRNGstate();
}
SEXP rgeos_geospolygon2Polygons(SEXP env, GEOSGeom geom, SEXP ID) {
GEOSContextHandle_t GEOShandle = getContextHandle(env);
int pc=0;
int type = GEOSGeomTypeId_r(GEOShandle, geom);
int empty = GEOSisEmpty_r(GEOShandle, geom);
int ngeom = GEOSGetNumGeometries_r(GEOShandle, geom);
ngeom = ngeom ? ngeom : 1;
int npoly = 0;
for (int i=0; i<ngeom; i++) {
GEOSGeom GC = (type == GEOS_MULTIPOLYGON && !empty) ?
(GEOSGeometry *) GEOSGetGeometryN_r(GEOShandle, geom, i) :
geom;
int GCempty = GEOSisEmpty_r(GEOShandle, GC);
int GCpolys = (GCempty) ? 1 :
GEOSGetNumInteriorRings_r(GEOShandle, GC) + 1;
npoly += GCpolys;
}
SEXP polys;
PROTECT(polys = NEW_LIST(npoly)); pc++;
int *comm = (int *) R_alloc((size_t) npoly, sizeof(int));
int *po = (int *) R_alloc((size_t) npoly, sizeof(int));
double *areas = (double *) R_alloc((size_t) npoly, sizeof(double));
double totalarea = 0.0;
int k = 0;
for (int i=0; i<ngeom; i++) {
GEOSGeom GC = (type == GEOS_MULTIPOLYGON && !empty) ?
(GEOSGeometry *) GEOSGetGeometryN_r(GEOShandle, geom, i) :
geom;
if (GEOSisEmpty_r(GEOShandle, GC)) {
SEXP ringDir,area,labpt,hole;
PROTECT(ringDir = NEW_INTEGER(1));
INTEGER_POINTER(ringDir)[0] = 1;
PROTECT(labpt = NEW_NUMERIC(2));
NUMERIC_POINTER(labpt)[0] = NA_REAL;
NUMERIC_POINTER(labpt)[1] = NA_REAL;
PROTECT(area = NEW_NUMERIC(1));
NUMERIC_POINTER(area)[0] = 0.0;
PROTECT(hole = NEW_LOGICAL(1));
LOGICAL_POINTER(hole)[0] = TRUE;
SEXP poly;
PROTECT(poly = NEW_OBJECT(MAKE_CLASS("Polygon")));
SET_SLOT(poly, install("ringDir"), ringDir);
SET_SLOT(poly, install("labpt"), labpt);
SET_SLOT(poly, install("area"), area);
SET_SLOT(poly, install("hole"), hole);
SET_SLOT(poly, install("coords"), R_NilValue);
SET_VECTOR_ELT(polys, k, poly);
UNPROTECT(5);
comm[k] = 0;
areas[k] = 0;
po[k] = k + R_OFFSET;
// modified 131004 RSB
// https://stat.ethz.ch/pipermail/r-sig-geo/2013-October/019470.html
// warning("rgeos_geospolygon2Polygons: empty Polygons object");
error("rgeos_geospolygon2Polygons: empty Polygons object");
k++;
} else {
GEOSGeom lr = (GEOSGeometry *) GEOSGetExteriorRing_r(GEOShandle, GC);
if (lr == NULL)
error("rgeos_geospolygon2Polygons: exterior ring failure");
SET_VECTOR_ELT(polys, k, rgeos_geosring2Polygon(env, lr, FALSE));
comm[k] = 0;
areas[k] = NUMERIC_POINTER( GET_SLOT(VECTOR_ELT(polys,k), install("area")) )[0];
totalarea += areas[k];
po[k] = k + R_OFFSET;
int ownerk = k + R_OFFSET;
k++;
int nirs = GEOSGetNumInteriorRings_r(GEOShandle, GC);
for (int j=0; j<nirs; j++) {
lr = (GEOSGeometry *) GEOSGetInteriorRingN_r(GEOShandle, GC, j);
if (lr == NULL)
error("rgeos_geospolygon2Polygons: interior ring failure");
SET_VECTOR_ELT(polys, k, rgeos_geosring2Polygon(env, lr, TRUE));
comm[k] = ownerk;
areas[k] = NUMERIC_POINTER( GET_SLOT(VECTOR_ELT(polys,k), install("area")) )[0];
po[k] = k + R_OFFSET;
k++;
}
}
}
SEXP plotOrder;
PROTECT(plotOrder = NEW_INTEGER(npoly)); pc++;
revsort(areas, po, npoly);
for (int i=0; i<npoly; i++)
INTEGER_POINTER(plotOrder)[i] = po[i];
SEXP labpt = GET_SLOT(VECTOR_ELT(polys,po[0]-1), install("labpt"));
SEXP area;
PROTECT(area = NEW_NUMERIC(1)); pc++;
NUMERIC_POINTER(area)[0] = totalarea;
SEXP comment;
PROTECT(comment = NEW_CHARACTER(1)); pc++;
char *buf;
int nc;
nc = (int) (ceil(log10(npoly)+1.0))+1;
buf = (char *) R_alloc((size_t) (npoly*nc)+1, sizeof(char));
SP_PREFIX(comm2comment)(buf, (npoly*nc)+1, comm, npoly);
SET_STRING_ELT(comment, 0, mkChar((const char*) buf));
SEXP ans;
PROTECT(ans = NEW_OBJECT(MAKE_CLASS("Polygons"))); pc++;
SET_SLOT(ans, install("Polygons"), polys);
SET_SLOT(ans, install("plotOrder"), plotOrder);
SET_SLOT(ans, install("labpt"), labpt);
SET_SLOT(ans, install("ID"), ID);
SET_SLOT(ans, install("area"), area);
setAttrib(ans, install("comment"), comment);
UNPROTECT(pc);
return(ans);
}
SEXP rgeos_geosring2Polygon(SEXP env, GEOSGeom lr, int hole) {
GEOSContextHandle_t GEOShandle = getContextHandle(env);
int pc=0;
GEOSCoordSeq s = (GEOSCoordSequence *) GEOSGeom_getCoordSeq_r(GEOShandle, lr);
if (s == NULL)
error("rgeos_geosring2Polygon: CoordSeq failure");
unsigned int n;
if (GEOSCoordSeq_getSize_r(GEOShandle, s, &n) == 0)
error("rgeos_geosring2Polygon: CoordSeq failure");
// Get coordinates
SEXP crd;
PROTECT(crd = rgeos_crdMatFixDir(rgeos_CoordSeq2crdMat(env, s, FALSE, hole), hole)); pc++;
// Calculate area
GEOSGeom p = GEOSGeom_createPolygon_r(GEOShandle,GEOSGeom_clone_r(GEOShandle,lr),NULL,0);
if (p == NULL)
error("rgeos_geosring2Polygon: unable to create polygon");
SEXP area;
PROTECT(area = NEW_NUMERIC(1)); pc++;
NUMERIC_POINTER(area)[0] = 0.0;
if (!GEOSArea_r(GEOShandle, p, NUMERIC_POINTER(area)))
error("rgeos_geosring2Polygon: area calculation failure");
// Calculate label position
SEXP labpt;
PROTECT(labpt = NEW_NUMERIC(2)); pc++;
GEOSGeom centroid = GEOSGetCentroid_r(GEOShandle, p);
double xc, yc;
rgeos_Pt2xy(env, centroid, &xc, &yc);
if (!R_FINITE(xc) || !R_FINITE(yc)) {
xc = 0.0;
yc = 0.0;
for(int i=0; i != n; i++) {
xc += NUMERIC_POINTER(crd)[i];
yc += NUMERIC_POINTER(crd)[(int) (n) +i];
}
xc /= n;
yc /= n;
}
NUMERIC_POINTER(labpt)[0] = xc;
NUMERIC_POINTER(labpt)[1] = yc;
GEOSGeom_destroy_r(GEOShandle, centroid);
GEOSGeom_destroy_r(GEOShandle, p);
// Get ring direction
SEXP ringDir;
PROTECT(ringDir = NEW_INTEGER(1)); pc++;
INTEGER_POINTER(ringDir)[0] = hole ? -1 : 1;
// Get hole status
SEXP Hole;
PROTECT(Hole = NEW_LOGICAL(1)); pc++;
LOGICAL_POINTER(Hole)[0] = hole;
SEXP ans;
PROTECT(ans = NEW_OBJECT(MAKE_CLASS("Polygon"))); pc++;
SET_SLOT(ans, install("ringDir"), ringDir);
SET_SLOT(ans, install("labpt"), labpt);
SET_SLOT(ans, install("area"), area);
SET_SLOT(ans, install("hole"), Hole);
SET_SLOT(ans, install("coords"), crd);
SEXP valid;
PROTECT(valid = SP_PREFIX(Polygon_validate_c)(ans)); pc++;
if (!isLogical(valid)) {
UNPROTECT(pc);
if (isString(valid))
error(CHAR(STRING_ELT(valid, 0)));
else
error("invalid Polygon object");
}
UNPROTECT(pc);
return(ans);
}
SEXP rgeos_geospolygon2SpatialPolygons(SEXP env, GEOSGeom geom, SEXP p4s, SEXP IDs, int ng) {
GEOSContextHandle_t GEOShandle = getContextHandle(env);
int pc=0;
SEXP bbox, comment;
PROTECT(bbox = rgeos_geom2bbox(env, geom)); pc++;
int type = GEOSGeomTypeId_r(GEOShandle, geom);
int empty = GEOSisEmpty_r(GEOShandle, geom);
if (ng < 1)
error("rgeos_geospolygon2SpatialPolygons: invalid number of geometries");
if (ng > length(IDs))
error("rgeos_geospolygon2SpatialPolygons: ng > length(IDs)");
SEXP pls;
PROTECT(pls = NEW_LIST(ng)); pc++;
double *areas = (double *) R_alloc((size_t) ng, sizeof(double));
int *po = (int *) R_alloc((size_t) ng, sizeof(int));
for (int i=0; i<ng; i++) {
GEOSGeom GC = (type == GEOS_GEOMETRYCOLLECTION && !empty) ?
(GEOSGeometry *) GEOSGetGeometryN_r(GEOShandle, geom, i) :
geom;
if (GC == NULL)
error("rgeos_geospolygon2SpatialPolygons: unable to get subgeometry");
SEXP poly, ID;
PROTECT( ID = NEW_CHARACTER(1));
SET_STRING_ELT(ID,0,STRING_ELT(IDs, i));
PROTECT( poly = rgeos_geospolygon2Polygons(env, GC, ID) );
areas[i] = NUMERIC_POINTER(GET_SLOT(poly, install("area")))[0];
SET_VECTOR_ELT(pls, i, poly);
po[i] = i + R_OFFSET;
UNPROTECT(2);
}
revsort(areas, po, ng);
SEXP plotOrder;
PROTECT(plotOrder = NEW_INTEGER(ng)); pc++;
for (int i=0; i<ng; i++)
INTEGER_POINTER(plotOrder)[i] = po[i];
SEXP ans;
PROTECT(ans = NEW_OBJECT(MAKE_CLASS("SpatialPolygons"))); pc++;
SET_SLOT(ans, install("polygons"), pls);
SET_SLOT(ans, install("proj4string"), p4s);
SET_SLOT(ans, install("plotOrder"), plotOrder);
SET_SLOT(ans, install("bbox"), bbox);
// RSB 120417 add top-level comment that all member Polygons
// objects have comment set
PROTECT(comment = NEW_CHARACTER(1)); pc++;
SET_STRING_ELT(comment, 0, mkChar("TRUE"));
setAttrib(ans, install("comment"), comment);
UNPROTECT(pc);
return(ans);
}
SEXP rgeos_convert_geos2R(SEXP env, GEOSGeom geom, SEXP p4s, SEXP id) {
GEOSContextHandle_t GEOShandle = getContextHandle(env);
int type = GEOSGeomTypeId_r(GEOShandle, geom);
int ng = GEOSGetNumGeometries_r(GEOShandle, geom);
if (ng == -1) error("rgeos_convert_geos2R: invalid number of subgeometries");
if (type == GEOS_GEOMETRYCOLLECTION && ng==0 && GEOSisEmpty_r(GEOShandle,geom)) {
GEOSGeom_destroy_r(GEOShandle, geom);
return(R_NilValue);
}
ng = ng ? ng : 1; // Empty MULTI type geometries return size 0
int pc=0;
SEXP ans=NULL;
switch(type) { // Determine appropriate conversion for the collection
case -1:
error("rgeos_convert_geos2R: unknown geometry type");
break;
case GEOS_POINT:
case GEOS_MULTIPOINT:
PROTECT( ans = rgeos_geospoint2SpatialPoints(env, geom, p4s, id, ng) ); pc++;
break;
case GEOS_LINEARRING:
PROTECT( ans = rgeos_geosring2SpatialRings(env, geom, p4s, id, ng)); pc++;
break;
case GEOS_LINESTRING:
case GEOS_MULTILINESTRING:
PROTECT( ans = rgeos_geosline2SpatialLines(env, geom, p4s, id, 1) ); pc++;
break;
case GEOS_POLYGON:
case GEOS_MULTIPOLYGON:
PROTECT( ans = rgeos_geospolygon2SpatialPolygons(env, geom,p4s, id, 1) ); pc++;
break;
case GEOS_GEOMETRYCOLLECTION:
{
int gctypes[] = {0,0,0,0,0,0,0,0};
int gctypen[] = {0,0,0,0,0,0,0,0};
int n=0;
int *types = (int *) R_alloc((size_t) ng, sizeof(int));
for (int i=0; i<ng; i++) {
const GEOSGeometry *subgeom = GEOSGetGeometryN_r(GEOShandle, geom, i);
if (subgeom == NULL)
error("rgeos_convert_geos2R: unable to retrieve subgeometry");
int ns = GEOSGetNumGeometries_r(GEOShandle, subgeom);
if (ns == -1) error("rgeos_convert_geos2R: invalid number of geometries in subgeometry");
ns = ns ? ns : 1;
n += ns;
types[i] = GEOSGeomTypeId_r(GEOShandle, subgeom);
if (types[i] == GEOS_GEOMETRYCOLLECTION)
error("Geometry collections may not contain other geometry collections");
gctypes[ types[i] ] += 1;
gctypen[ types[i] ] += ns;
}
int isPoint = gctypes[GEOS_POINT] + gctypes[GEOS_MULTIPOINT];
int isLine = gctypes[GEOS_LINESTRING] + gctypes[GEOS_MULTILINESTRING];
int isPoly = gctypes[GEOS_POLYGON] + gctypes[GEOS_MULTIPOLYGON];
int isRing = gctypes[GEOS_LINEARRING];
int isGC = gctypes[GEOS_GEOMETRYCOLLECTION];
if ( isPoint && !isLine && !isPoly && !isRing && !isGC ) {
PROTECT( ans = rgeos_geospoint2SpatialPoints(env, geom, p4s, id, n) ); pc++;
} else if ( isLine && !isPoint && !isPoly && !isRing && !isGC ) {
PROTECT( ans = rgeos_geosline2SpatialLines(env, geom, p4s, id, ng) ); pc++;
} else if ( isPoly && !isPoint && !isLine && !isRing && !isGC ) {
PROTECT( ans = rgeos_geospolygon2SpatialPolygons(env, geom, p4s,id, ng) ); pc++;
} else if ( isRing && !isPoint && !isLine && !isPoly && !isGC ) {
PROTECT( ans = rgeos_geosring2SpatialRings(env, geom, p4s, id, ng) ); pc++;
} else {
//Rprintf("isPoint: %d isLine: %d isPoly: %d isRing: %d isGC: %d\n",isPoint, isLine, isPoly, isRing, isGC);
int m = MAX(MAX(MAX(isPoint,isLine),isPoly),isRing);
if (length(id) < m) {
char buf[BUFSIZ];
PROTECT(id = NEW_CHARACTER(m)); pc++;
for (int i=0;i<m;i++) {
sprintf(buf,"%d",i);
SET_STRING_ELT(id, i, COPY_TO_USER_STRING(buf));
}
}
GEOSGeom *GCS[4];
GCS[0] = (GEOSGeom *) R_alloc((size_t) isPoint, sizeof(GEOSGeom));
GCS[1] = (GEOSGeom *) R_alloc((size_t) isLine, sizeof(GEOSGeom));
GCS[2] = (GEOSGeom *) R_alloc((size_t) isRing, sizeof(GEOSGeom));
GCS[3] = (GEOSGeom *) R_alloc((size_t) isPoly, sizeof(GEOSGeom));
SEXP ptID, lID, rID, pID;
PROTECT(ptID = NEW_CHARACTER(isPoint)); pc++;
PROTECT(lID = NEW_CHARACTER(isLine)); pc++;
PROTECT(rID = NEW_CHARACTER(isRing)); pc++;
PROTECT(pID = NEW_CHARACTER(isPoly)); pc++;
int typei[] = {0,0,0,0};
for (int i=0; i<ng; i++) {
const GEOSGeometry *subgeom = GEOSGetGeometryN_r(GEOShandle, geom, i);
if (subgeom == NULL)
error("rgeos_convert_geos2R: unable to retrieve subgeometry");
int j = -1;
SEXP cur_id=NULL;
if (types[i]==GEOS_POINT || types[i]==GEOS_MULTIPOINT) {
j=0;
cur_id=ptID;
} else if (types[i]==GEOS_LINESTRING || types[i]==GEOS_MULTILINESTRING) {
j=1;
cur_id=lID;
} else if (types[i]==GEOS_LINEARRING) {
j=2;
cur_id=rID;
} else if (types[i]==GEOS_POLYGON || types[i]==GEOS_MULTIPOLYGON) {
j=3;
cur_id=pID;
}
if (GCS[j] == NULL)
error("rgeos_convert_geos2R: GCS element is NULL (this should never happen).");
GCS[j][ typei[j] ] = GEOSGeom_clone_r(GEOShandle, subgeom);
SET_STRING_ELT(cur_id, typei[j], STRING_ELT(id,typei[j]));
typei[j]++;
}
SEXP points = R_NilValue;
SEXP lines = R_NilValue;
SEXP rings = R_NilValue;
SEXP polys = R_NilValue;
if (isPoint) {
GEOSGeom ptGC = GEOSGeom_createCollection_r(GEOShandle, GEOS_GEOMETRYCOLLECTION, GCS[0], (unsigned int) isPoint);
PROTECT( points = rgeos_convert_geos2R(env, ptGC, p4s, ptID) ); pc++;
}
if (isLine) {
GEOSGeom lGC = GEOSGeom_createCollection_r(GEOShandle, GEOS_GEOMETRYCOLLECTION, GCS[1], (unsigned int) isLine);
PROTECT( lines = rgeos_convert_geos2R(env, lGC, p4s, lID) ); pc++;
}
if (isRing) {
GEOSGeom rGC = GEOSGeom_createCollection_r(GEOShandle, GEOS_GEOMETRYCOLLECTION, GCS[2], (unsigned int) isRing);
PROTECT( rings = rgeos_convert_geos2R(env, rGC, p4s, rID) ); pc++;
}
if (isPoly) {
GEOSGeom pGC = GEOSGeom_createCollection_r(GEOShandle, GEOS_GEOMETRYCOLLECTION, GCS[3], (unsigned int) isPoly);
PROTECT( polys = rgeos_convert_geos2R(env, pGC, p4s, pID) ); pc++;
}
PROTECT(ans = NEW_OBJECT(MAKE_CLASS("SpatialCollections"))); pc++;
SET_SLOT(ans, install("proj4string"), p4s);
SET_SLOT(ans, install("pointobj"), points);
SET_SLOT(ans, install("lineobj"), lines);
SET_SLOT(ans, install("ringobj"), rings);
SET_SLOT(ans, install("polyobj"), polys);
SEXP plotOrder;
PROTECT(plotOrder = NEW_INTEGER(4)); pc++;
INTEGER_POINTER(plotOrder)[0] = 4;
INTEGER_POINTER(plotOrder)[1] = 3;
INTEGER_POINTER(plotOrder)[2] = 2;
INTEGER_POINTER(plotOrder)[3] = 1;
SET_SLOT(ans, install("plotOrder"), plotOrder);
SEXP bbox;
PROTECT(bbox = rgeos_geom2bbox(env, geom)); pc++;
SET_SLOT(ans, install("bbox"), bbox);
}
break;
}
default:
error("rgeos_convert_geos2R: Unknown geometry type");
}
GEOSGeom_destroy_r(GEOShandle, geom);
UNPROTECT(pc);
return(ans);
}
SEXP svi(SEXP R_T, SEXP R_P, SEXP R_j, SEXP R_p, SEXP R_nIter, SEXP R_m) {
int T, P, nIter, k, h;
int *jM, *pM, iter, i, j;
double *mPostU, *vPostU, *mPostV, *vPostV, *mPostB, *vPostB, *mPriorU,
*mPriorV, *vPriorUi, *vPriorUh, *vPriorVj, *vPriorVh,
vPriorB, mPriorB, mPred, vPred, e, *e0, rho;
int *nZerosAuxi, *nOnesAuxi, *nZerosAuxj, *nOnesAuxj, *nOnesSampling,
*nZerosSampling;
/* We read in the random number generator seed */
GetRNGstate();
/* We map the R variables to c variables */
jM = INTEGER_POINTER(R_j);
pM = INTEGER_POINTER(R_p);
T = *INTEGER_POINTER(R_T);
P = *INTEGER_POINTER(R_P);
nIter = *INTEGER_POINTER(R_nIter);
mPostU = NUMERIC_POINTER(getListElement(R_m, "mPostU"));
vPostU = NUMERIC_POINTER(getListElement(R_m, "vPostU"));
mPostV = NUMERIC_POINTER(getListElement(R_m, "mPostV"));
vPostV = NUMERIC_POINTER(getListElement(R_m, "vPostV"));
mPostB = NUMERIC_POINTER(getListElement(R_m, "mPostB"));
vPostB = NUMERIC_POINTER(getListElement(R_m, "vPostB"));
mPriorU = NUMERIC_POINTER(getListElement(R_m, "mPriorU"));
mPriorV = NUMERIC_POINTER(getListElement(R_m, "mPriorV"));
vPriorUi = NUMERIC_POINTER(getListElement(R_m, "vPriorUi"));
vPriorUh = NUMERIC_POINTER(getListElement(R_m, "vPriorUh"));
mPriorU = NUMERIC_POINTER(getListElement(R_m, "mPriorU"));
vPriorVj = NUMERIC_POINTER(getListElement(R_m, "vPriorVj"));
vPriorVh = NUMERIC_POINTER(getListElement(R_m, "vPriorVh"));
mPriorB = *NUMERIC_POINTER(getListElement(R_m, "mPriorB"));
vPriorB = *NUMERIC_POINTER(getListElement(R_m, "vPriorB"));
e0 = NUMERIC_POINTER(getListElement(R_m, "e0"));
k = *INTEGER_POINTER(getListElement(R_m, "k"));
nOnesAuxi = INTEGER_POINTER(getListElement(R_m, "nOnesAuxi"));
nOnesAuxj = INTEGER_POINTER(getListElement(R_m, "nOnesAuxj"));
nZerosAuxi = INTEGER_POINTER(getListElement(R_m, "nZerosAuxi"));
nZerosAuxj = INTEGER_POINTER(getListElement(R_m, "nZerosAuxj"));
nOnesSampling = INTEGER_POINTER(getListElement(R_m, "nOnesSampling"));
nZerosSampling =
INTEGER_POINTER(getListElement(R_m, "nZerosSampling"));
/* We start the stochastic optimization */
for (iter = 1 ; iter <= nIter ; iter++) {
rho = 0.01;
if (unif_rand() <= (double) nOnesSampling[ T - 1 ] /
(nOnesSampling[ T - 1 ] + nZerosSampling[ T - 1 ])) {
/* We sample the row and column of a positive entry */
samplePositiveEntry(jM, pM, T, nOnesSampling, &i, &j);
/* We compute the predictive mean and variance */
mPred = 0;
vPred = 0;
for (h = 0 ; h < k ; h++) {
mPred += mPostU[ i + h * T ] *
mPostV[ j + h * P ];
vPred += mPostU[ i + h * T ] *
mPostU[ i + h * T ] *
vPostV[ j + h * P ] +
vPostU[ i + h * T ] *
mPostV[ j + h * P ] *
mPostV[ j + h * P ] +
vPostU[ i + h * T ] *
vPostV[ j + h * P ];
}
mPred += *mPostB;
vPred += *vPostB;
/* We refine the parameters for the i-th row of U */
refineRowUPositive(mPostU, vPostU, mPostV, vPostV,
vPriorUi, vPriorUh, mPriorU, &mPred, &vPred,
i, j, T, P, k, nOnesSampling, nZerosSampling,
nOnesAuxi, nZerosAuxi, rho);
/* We refine the parameters for the i-th row of V */
refineRowVPositive(mPostU, vPostU, mPostV, vPostV,
vPriorVj, vPriorVh, mPriorV, &mPred, &vPred,
i, j, T, P, k, nOnesSampling, nZerosSampling,
nOnesAuxj, nZerosAuxj, rho);
/* We refine the global bias parameter */
refineBiasPositive(mPostB, vPostB, vPriorB, mPriorB,
mPred, vPred, T, rho, nOnesSampling,
nZerosSampling);
} else {
/* We sample the row and column of a negative entry */
sampleNegativeEntry(jM, pM, T, P, nZerosSampling,
&i, &j);
/* We compute the predictive mean and variance */
mPred = 0;
vPred = 0;
for (h = 0 ; h < k ; h++) {
mPred += mPostU[ i + h * T ] *
mPostV[ j + h * P ];
vPred += mPostU[ i + h * T ] *
mPostU[ i + h * T ] *
vPostV[ j + h * P ] +
vPostU[ i + h * T ] *
mPostV[ j + h * P ] *
mPostV[ j + h * P ] +
vPostU[ i + h * T ] *
vPostV[ j + h * P ];
}
mPred += *mPostB;
vPred += *vPostB;
/* We refine the parameters for the i-th row of U */
refineRowUNegative(mPostU, vPostU, mPostV, vPostV,
vPriorUi, vPriorUh, mPriorU, &mPred, &vPred,
i, j, T, P, k, e0, nOnesSampling,
nZerosSampling, nOnesAuxi, nZerosAuxi, rho);
/* We refine the parameters for the i-th row of V */
refineRowVNegative(mPostU, vPostU, mPostV, vPostV,
vPriorVj, vPriorVh, mPriorV, &mPred, &vPred,
i, j, T, P, k, e0, nOnesSampling,
nZerosSampling, nOnesAuxj, nZerosAuxj, rho);
/* We refine the global bias parameter */
refineBiasNegative(mPostB, vPostB, vPriorB, mPriorB,
mPred, vPred, T, rho, nZerosSampling,
nOnesSampling, e0);
}
if (iter % 100000 == 0) {
fprintf(stdout, "%d\n", iter);
fflush(stdout);
}
}
/* We write out the random number generator seed */
PutRNGstate();
/* We free memory */
return R_m;
}
SEXP count_m( SparseAdjacency &G, int k, vector<int*> *occurrences, int &n_prot) {
// unused SEXP S_M_List;
int64_t TotalCount = occurrences -> size();
vector<int*>::const_iterator it = occurrences -> begin();
// unused int *ptr = *it;
// for ( int64_t count=0; count < TotalCount; count++, it++) {
// printList( "Occurrence : ", *it, *it + k, " ", true);
// }
int *mat;
int *gamma = new int[k];
// Store 2 references : on canonic form and on an occurence
canonic_list_t *canonic_list = new canonic_list_t[TotalCount];
// To Store canonic form
int *canonic = new int[TotalCount * k*k];
// To sort canonic form (used by canonic_order function)
sort_canonic_nbr_elmnt = k*k;
int directed;
if(G.getSymmetry())
directed=0 ;
else
directed=1;
// tempory storage for permutations, transpositions
int *tempo = new int[k];
int *transp = new int[k*k];
//
// Compute canonic form and reoder occurrence indexes
//
for ( int64_t count=0; count < TotalCount; count++, it++) {
// Extract motif
// The matrix must be transposed (true) for nauty
mat = G.getMatrix( *it, k, false );
// Get canonic form
// ??? Perf call getCanonic once
int *cur_canonic = &canonic[k*k * count];
getCanonic( mat , k, directed, cur_canonic, gamma );
delete [] mat;
canonic_list[count].canonic = cur_canonic;
canonic_list[count].occurrence = *it;
//
// Print canonic form
// printList( "Occurences, canonic ", *it, *it+k, " ", false);
// cout << ", " ;
//
// Permute nodes
//
int *node=*it;
for( int i=0; i < k; i++){
tempo[i] = node[gamma[i]];
}
// Permute node in the occurence list
for( int i=0; i < k; i++){
node[i] = tempo[i];
}
// Print cannonic
// printList("", cur_canonic, cur_canonic + k*k, "", true);
// Print gamma
// printList( " gamma : ", gamma, gamma + k);
}
//
// Sort occurrences according to the canonical form of m
//
qsort( canonic_list, TotalCount, sizeof(canonic_list_t), canonic_order);
//
// Get refences where start and end a motif( canonic form)
//
//
// Build list of reference (pointer of type : canonic_list_t*)
// pointing to the same canonical form of m.
// Stored in the MotifEnd, MotifStart (STL) list
//
vector<canonic_list_t*> MotifEnd, MotifStart;
int nbr_motif=0;
it = occurrences -> begin( );
canonic_list_t *prev_canonic = &canonic_list[0];
MotifStart.push_back( &canonic_list[ 0 ] );
for ( int64_t count=0; count < TotalCount; count++, it++) {
// If the current canonc form is equal to the previous one
if( canonic_order( &canonic_list[count], prev_canonic ) ) {
// New canonic form
prev_canonic = &canonic_list[count];
MotifEnd.push_back( &canonic_list[count] );
MotifStart.push_back( prev_canonic );
nbr_motif = 0;
} else{
nbr_motif++;
}
}
MotifEnd.push_back( &canonic_list[ TotalCount ] );
//
// For each motif m, the occurence list of m is sorted
// by ignoring one node (belonging to the same TC - the
// remove index is stored in "remove" field)
//
vector<canonic_list_t*>::const_iterator ite = MotifEnd.begin();
// unused vector<canonic_list_t*>::const_iterator ite_end = MotifEnd.end();
SEXP S_M_CanonicList;
SEXP S_M_CountList;
PROTECT( S_M_CanonicList=allocVector( VECSXP, MotifStart.size() )); n_prot++;
PROTECT( S_M_CountList=allocVector( INTSXP, MotifStart.size() )); n_prot++;
int *M_CountList = INTEGER_POINTER( S_M_CountList );
// ID of the sorted motif m
int m_index = 0;
for( vector<canonic_list_t*>::const_iterator its = MotifStart.begin(),
its_end= MotifStart.end();
its != its_end; its++, ite++, m_index++ ) {
# if( MSG)
// Print cannonic
ptr = (*its) -> canonic;
printList("", ptr, ptr + k*k, "", false);
cout << ", " << endl ;
# endif
// Store Canonic or Adjacency matrix
SEXP S_Canonic;
// Transpose canonic
int *can = (*its) -> canonic ;
for ( int i=0; i < k; i++){
for ( int j=0; j < k; j++){
// transp[ i + k * j] = can[ j + k * i];
transp[ i + k * j] = can[ i + k * j];
}
}
AllocateAndStoreInSEXP( transp, k*k, S_Canonic, n_prot );
// Add to canonic list
SET_VECTOR_ELT( S_M_CanonicList, m_index, S_Canonic );
// Store counts
M_CountList[ m_index ] = (int) ((*ite) -(*its)) ;
}
delete [] canonic;
delete [] canonic_list;
SEXP S_Result;
// Fuse the two fields
PROTECT( S_Result = allocVector( VECSXP, 2 )); n_prot++;
SET_VECTOR_ELT( S_Result, 0, S_M_CanonicList );
SET_VECTOR_ELT( S_Result, 1, S_M_CountList );
delete [] gamma;
delete [] tempo;
delete [] transp;
return S_Result;
}
SEXP getExceptional( int *G_edges, int G_nnodes,
int M_Min_nnodes, int M_Max_nnodes,
int *NodeToClass, double *Pi, int NbrClasses,
double PValue, int Directed,
int &n_prot) {
//
// Get all occurrences of size k = M_nnodes
//
//
// Find all motif with size k
//
FindMotif find( StoreMode, 0);
FindMotif f( CountMode, 0);
vector<int*> *list;
SparseAdjacency G( G_edges, G_nnodes, true );
// G.print( "G");
SparseAdjacency H( G_edges, G_nnodes, ! Directed );
// H.print( "H");
SEXP S_ReturnList;
// All components are store even if they are NULL
PROTECT( S_ReturnList = allocVector( VECSXP,
M_Max_nnodes - M_Min_nnodes + 1)); n_prot++;
// Index in the Returned list
int i_k = 0;
/// Previous non NULL value of k index
int prev_k_index = -1;
for ( int k= M_Min_nnodes; k <= M_Max_nnodes; k++, i_k++) {
// To optimize the motifs
// int perm_0[k-1];
int *perm_0 = new int[k];
int *perm_1 = new int[k];
SEXP S_Result;
// Occurence list 'list' must be deallocated"
// Doesn't belong to 'find'
// TODO To improve
find.clearFoundList();
list = find.findAllMotifs( G, k );
S_Result = sort_m_mp_u( H, G_nnodes, k, list,
Pi, NodeToClass, NbrClasses,
0, -1,
PValue,
n_prot, false );
if ( S_Result != R_NilValue ) {
// Store k value
SEXP S_k;
PROTECT( S_k = allocVector( INTSXP, 1) ); n_prot++;
int *p_k = INTEGER_POINTER( S_k );
p_k[0] = k;
SEXP S_Struct;
PROTECT( S_Struct = allocVector( VECSXP, 2 )); n_prot++;;
SET_VECTOR_ELT( S_Struct, 0, S_k );
SET_VECTOR_ELT( S_Struct, 1, S_Result );
SET_VECTOR_ELT( S_ReturnList, i_k, S_Struct );
SEXP S_Adj_1 = VECTOR_ELT( S_Result, 0 );
int MotifNbr_1 = LENGTH( S_Adj_1 );
// Skip First motif
// if ( prev_k_index != -1 ) {
for ( int k_index = 0; k_index <= (prev_k_index); k_index++ ) {
SEXP S_k_value = VECTOR_ELT(
VECTOR_ELT( S_ReturnList,
k_index ),
0 );
int prev_k_value = INTEGER_POINTER( S_k_value ) [0];
// Get Adjacency matrix with i-1 nodes
SEXP S_Adj_0 = VECTOR_ELT(
VECTOR_ELT(
VECTOR_ELT( S_ReturnList,
k_index ),
1 ),
0);
// Get M_list
SEXP S_m_0 = VECTOR_ELT(
VECTOR_ELT(
VECTOR_ELT( S_ReturnList,
k_index ),
1 ),
1);
int MotifNbr_0 = LENGTH( S_Adj_0 );
for(int m = 0; m < MotifNbr_0; m++ ) {
// Test NULL SEXP
if( VECTOR_ELT(S_Adj_0, m) != R_NilValue ) {
// int debug = LENGTH( VECTOR_ELT(S_Adj_0, m) );
int *adj_0 = INTEGER_POINTER( VECTOR_ELT(S_Adj_0, m) );
// printList( "canonic ", adj_0, adj_0+ (k-1)*(k-1), " ", true);
SparseAdjacency motif0( adj_0, prev_k_value, "dense", (Directed == 0) );
SparseAdjacency motif0_canon( motif0 );
motif0.optimizeConnexity( perm_0 );
// motif0.print( "motif opt 0" );
// printList( " perm 0 ", perm_0, perm_0 + (k-1), true );
// Number of Del class
SEXP S_m_mp_0 = VECTOR_ELT( S_m_0, m );
int m_mp_len_0 = LENGTH( S_m_mp_0 );
int *del_class_0 = new int[ m_mp_len_0 ];
// get the first node ID of the del class
getDelClassNode( S_m_mp_0, m_mp_len_0, del_class_0 );
// printList( "Del class 0 ", del_class_0,
// del_class_0 + m_mp_len_0, " ", true);
// Get Degree of delete node
// int deg_in_0 = 0;
// int deg_out_0 = 0;
for(int p = 0; p < MotifNbr_1; p++ ) {
// Test NULL SEXP
if( VECTOR_ELT(S_Adj_1, p) != R_NilValue ) {
// int debug_1 = LENGTH( VECTOR_ELT(S_Adj_1, p) );
int *adj_1 = INTEGER_POINTER( VECTOR_ELT(S_Adj_1, p) );
#if ( MSG > 0 )
printList( "canonic 1 ", adj_1, adj_1 + (k)*(k), " ", true);
#endif
SparseAdjacency motif1( adj_1, k, "dense", (Directed == 0) );
SparseAdjacency motif1_canonic( motif1 );
motif1.optimizeConnexity( perm_1 );
// get M List
SEXP S_m_1 = VECTOR_ELT(
VECTOR_ELT(
VECTOR_ELT( S_ReturnList,
i_k ),
1 ),
1);
// Number of Del class
SEXP S_m_mp_1 = VECTOR_ELT( S_m_1, p );
int m_mp_len_1 = LENGTH( S_m_mp_1 ) ;
int *del_class_1 = new int [ m_mp_len_1 ];
// get the first node ID of the del class
getDelClassNode( S_m_mp_1, m_mp_len_1, del_class_1 );
// printList( "Del class 1 ", del_class_1,
// del_class_1 + m_mp_len_1, " ", true);
// printList( "canonic ", adj_0, adj_0 + (k-1)*(k-1), " ", true);
// printList( "canonic ", adj_1, adj_1 + (k)*(k), " ", true);
for( int del_0 = 0; del_0 < m_mp_len_0; del_0++) {
if( del_class_0[del_0] >= 0 ) {
// Get Degree of delete node
int deg_in_0 = 0;
int deg_out_0 = 0;
if ( Directed ) {
deg_in_0 = motif0_canon.getRowSize( del_class_0[ del_0 ] );
deg_out_0 = motif0_canon.getColSize( del_class_0[ del_0] );
} else {
deg_in_0 = motif0_canon.getAllRowSize( del_class_0[ del_0 ] );
}
for( int del_1 = 0; del_1 < m_mp_len_1; del_1++) {
if( del_class_1[ del_1 ] >= 0 ) {
if( getPValue( S_m_mp_1, del_1 ) <= PValue ) {
if( getPValue( S_m_mp_0, del_0 ) <= PValue ) {
// Get Degree of delete node
int deg_in_1 = 0;
int deg_out_1 = 0;
if ( Directed ) {
deg_in_1 = motif1_canonic.getRowSize( del_class_1[ del_1 ] );
deg_out_1 = motif1_canonic.getColSize( del_class_1[ del_1 ] );
} else {
deg_in_1 = motif1_canonic.getAllRowSize( del_class_1[ del_1 ] );
}
// cout << "del_0 :" << del_0 << ", del_1 :" << del_1 << endl;
if ( ( deg_in_0 == deg_in_1 ) && (deg_out_0 == deg_out_1 ) ) {
int *color_0 = new int [ prev_k_value ];
int *color_1 = new int [ k ];
for( int *ptr=color_0,
*ptr_end= color_0 + (prev_k_value);
ptr != ptr_end; ptr++ ) {
*ptr=0;
}
for( int *ptr=color_1, *ptr_end= color_1 + (k);
ptr != ptr_end; ptr++ ) {
*ptr=0;
}
color_0[ perm_0[ del_class_0[ del_0 ] ]] = 1;
color_1[ perm_1[ del_class_1[ del_1 ] ]] = 1;
// printList( " color_0 ", color_0,color_0+ (k-1), true);
// printList( " color_1 ", color_1,color_1+ (k), true);
bool incl = f.isExactlyIncluded( motif0, motif1, color_0, color_1 );
if( incl ) {
setMotifFilter( S_m_mp_1, del_1, 0, 1, m, del_class_0[ del_0 ] );
} else {
setMotifFilter( S_m_mp_1, del_1, 1, 0, 0, 0 );
}
// cout << "( k=" << k-1 << ", motif=" << m << ", del="
// << del_class_0[ del_0 ] << ") ";
// cout << "( k=" << k << ", motif=" << p << ", del="
// << del_class_1[ del_1 ] << ") : " << incl << endl ;
delete [] color_0;
delete [] color_1;
} else {
// Different degrees => over-represented
setMotifFilter( S_m_mp_1, del_1, 1, 0, 0, 0);
}
} else {
// Parent motif not over-represented
setMotifFilter( S_m_mp_1, del_1, 1, 0, 0, 0);
}
} else {
// motif not over-represented
setMotifFilter( S_m_mp_1, del_1, 0, 0, 0, 0);
}
} // Valid DelClass - if( del_class_1[del_1] >= 0 )
} // for( int del_1 = 0; ...
} // Valid DelClass - if( del_class_0[del_0] >= 0 )
} // for( int del_0 = 0; ...
delete [] del_class_1;
} // if( VECTOR_ELT(S_Adj_1, p) != R_NilValue ) {
} // for(int p = 0; p < MotifNbr_1; p++ )
delete [] del_class_0;
} // if( VECTOR_ELT(S_Adj_0, m) != R_NilValue ) {
} // for(int m = 0; m < MotifNbr_0; m++ ) {
}
if ( prev_k_index == -1 ) {
// First value of k
SEXP S_m_0 = VECTOR_ELT(
VECTOR_ELT(
VECTOR_ELT( S_ReturnList, i_k ),
1 ),
1);
int MotifNbr_0 = LENGTH( S_m_0 );
for(int m = 0; m < MotifNbr_0; m++ ) {
SEXP S_m_mp_0 = VECTOR_ELT( S_m_0, m );
if ( S_m_mp_0 != R_NilValue ) {
int m_mp_len_0 = LENGTH( S_m_mp_0 );
for( int del_0 = 0; del_0 < m_mp_len_0; del_0++) {
if ( VECTOR_ELT( S_m_mp_0, del_0) != R_NilValue ) {
if( getPValue( S_m_mp_0, del_0 ) < PValue ) {
setMotifFilter( S_m_mp_0, del_0, 1, 0, 0, 0);
} else {
setMotifFilter( S_m_mp_0, del_0, 0, 0, 0, 0);
}
}
}
}
} // for(int m = 0; m < MotifNbr_0; m++ )
}
prev_k_index = i_k;
} else {
// S_Result NULL
}
// for ( vector<int*>::iterator it = list->begin(),
// it_end=list->end();it != it_end; it++ ) {
// delete [] *it;
// }
FindMotif::deallocateFoundList( list );
delete [] perm_0;
delete [] perm_1;
}
return S_ReturnList;
}
int *AllocateIntSEXP( size_t size, SEXP &S_exp, int &n_prot ) {
PROTECT( S_exp = allocVector( INTSXP, size) ); n_prot++;
int *out = INTEGER_POINTER( S_exp );
return out;
}
SEXP
m_log_lambda(SEXP X1, SEXP X1_Columns, SEXP X1_Rows,
SEXP X2, SEXP X2_Columns,
SEXP realS, SEXP OPTSimplicit_noisevar,
SEXP hp_prior, SEXP hp_posterior) {
long datalen;
int dim1, dim2, ncentroids;
double *Mu_mu, *S2_mu, *Mu_bar, *Mu_tilde,
*Alpha_ksi, *Beta_ksi, *Ksi_alpha, *Ksi_beta, *U_p, *prior_alpha,
*post_gamma, *log_lambda;
double *data1;
double *data2;
SEXP olog_lambda, oU_hat;
SEXP* U_hat;
double *Ns;
double implicit_noisevar;
/******************** input variables ********************/
/************ CONVERTED input variables ******************/
/* data */
PROTECT(X1 = AS_NUMERIC(X1));
data1 = NUMERIC_POINTER(X1);
dim1 = INTEGER_VALUE(X1_Columns);
datalen = INTEGER_VALUE(X1_Rows);
PROTECT(X2 = AS_NUMERIC(X2));
data2 = NUMERIC_POINTER(X2);
dim2 = INTEGER_VALUE(X2_Columns);
Ns = NUMERIC_POINTER(realS);
implicit_noisevar = NUMERIC_VALUE(OPTSimplicit_noisevar);
/* Converted Initial Values of Model Parameters */
if(dim1) {
Mu_mu = NUMERIC_POINTER(getListElement(hp_prior,"Mu_mu"));
S2_mu = NUMERIC_POINTER(getListElement(hp_prior,"S2_mu"));
Alpha_ksi = NUMERIC_POINTER(getListElement(hp_prior,"Alpha_ksi"));
Beta_ksi = NUMERIC_POINTER(getListElement(hp_prior,"Beta_ksi"));
Mu_bar = NUMERIC_POINTER(getListElement(hp_posterior,"Mu_bar"));
Mu_tilde = NUMERIC_POINTER(getListElement(hp_posterior,"Mu_tilde"));
Ksi_alpha = NUMERIC_POINTER(getListElement(hp_posterior,"Ksi_alpha"));
Ksi_beta = NUMERIC_POINTER(getListElement(hp_posterior,"Ksi_beta"));
}
if(dim2) {
U_p = NUMERIC_POINTER(getListElement(hp_prior,"U_p"));
oU_hat = getListElement(hp_posterior,"Uhat");
U_hat = &oU_hat;
}
prior_alpha = NUMERIC_POINTER(getListElement(hp_prior,"alpha"));
post_gamma = NUMERIC_POINTER(getListElement(hp_posterior,"gamma"));
ncentroids = INTEGER_POINTER( GET_DIM(getListElement(hp_posterior,"Mu_bar")) )[0];
/*printf("\nMu_mu ");
for(i=0; i< dim1;i++)
printf("%f ", Mu_mu[i]);
printf("\nS2_mu ");
for(i=0; i< dim1;i++)
printf("%f ", S2_mu[i]);
printf("\nAlpha_ksi ");
for(i=0; i< dim1;i++)
printf("%f ", Alpha_ksi[i]);
printf("\nBeta_ksi ");
for(i=0; i< dim1;i++)
printf("%f ", Beta_ksi[i]);
printf("\nMu_bar ");
for(i=0;i<ncentroids*dim1;i++)
printf("%f ", Mu_bar[i]);
printf("\nMu_tilde ");
for(i=0;i<ncentroids*dim1;i++)
printf("%f ", Mu_tilde[i]);
printf("\nKsi_alpha ");
for(i=0;i<ncentroids*dim1;i++)
printf("%f ", Ksi_alpha[i]);
printf("\nKsi_beta ");
for(i=0;i<ncentroids*dim1;i++)
printf("%f ", Ksi_beta[i]);
printf("\nprior_alpha = %f", *prior_alpha);
printf("\npost_gamma ");
for(i=0;i<2*ncentroids;i++)
printf("%f ", post_gamma[i]);
printf("ncentroids = %d\n", ncentroids);
printf("dim2 = %d\n",dim2);*/
/******************** output variables ********************/
PROTECT(olog_lambda = NEW_NUMERIC(datalen*ncentroids));
log_lambda = NUMERIC_POINTER(olog_lambda);
vdp_mk_log_lambda(Mu_mu, S2_mu, Mu_bar, Mu_tilde,
Alpha_ksi, Beta_ksi, Ksi_alpha, Ksi_beta,
post_gamma, log_lambda, prior_alpha,
U_p, U_hat,
datalen, dim1, dim2, data1, data2,
Ns, ncentroids, implicit_noisevar);
UNPROTECT(3);
return olog_lambda;
}
