SEXP minc2_apply(SEXP filenames, SEXP fn, SEXP have_mask, SEXP mask, SEXP mask_value, SEXP rho) { int result; mihandle_t *hvol, hmask; int i, v0, v1, v2, output_index, buffer_index; unsigned long start[3], count[3]; //unsigned long location[3]; int num_files; double *xbuffer, *xoutput, **full_buffer; double *xhave_mask, *xmask_value; double *mask_buffer; midimhandle_t dimensions[3]; misize_t sizes[3]; SEXP output, buffer; //SEXP R_fcall; /* allocate memory for volume handles */ num_files = LENGTH(filenames); hvol = malloc(num_files * sizeof(mihandle_t)); Rprintf("Number of volumes: %i\n", num_files); /* open the mask - if so desired */ xhave_mask = REAL(have_mask); if (xhave_mask[0] == 1) { result = miopen_volume(CHAR(STRING_ELT(mask, 0)), MI2_OPEN_READ, &hmask); if (result != MI_NOERROR) { error("Error opening mask: %s.\n", CHAR(STRING_ELT(mask, 0))); } } /* get the value inside that mask */ xmask_value = REAL(mask_value); /* open each volume */ for(i=0; i < num_files; i++) { result = miopen_volume(CHAR(STRING_ELT(filenames, i)), MI2_OPEN_READ, &hvol[i]); if (result != MI_NOERROR) { error("Error opening input file: %s.\n", CHAR(STRING_ELT(filenames,i))); } } /* get the file dimensions and their sizes - assume they are the same*/ miget_volume_dimensions( hvol[0], MI_DIMCLASS_SPATIAL, MI_DIMATTR_ALL, MI_DIMORDER_FILE, 3, dimensions); result = miget_dimension_sizes( dimensions, 3, sizes ); Rprintf("Volume sizes: %i %i %i\n", sizes[0], sizes[1], sizes[2]); /* allocate the output buffer */ PROTECT(output=allocVector(REALSXP, (sizes[0] * sizes[1] * sizes[2]))); xoutput = REAL(output); /* allocate the local buffer that will be passed to the function */ PROTECT(buffer=allocVector(REALSXP, num_files)); xbuffer = REAL(buffer); //PROTECT(R_fcall = lang2(fn, R_NilValue)); /* allocate first dimension of the buffer */ full_buffer = malloc(num_files * sizeof(double)); /* allocate second dimension of the buffer - big enough to hold one slice per subject at a time */ for (i=0; i < num_files; i++) { full_buffer[i] = malloc(sizes[1] * sizes[2] * sizeof(double)); } /* allocate buffer for mask - if necessary */ if (xhave_mask[0] == 1) { mask_buffer = malloc(sizes[1] * sizes[2] * sizeof(double)); } /* set start and count. start[0] will change during the loop */ start[0] = 0; start[1] = 0; start[2] = 0; count[0] = 1; count[1] = sizes[1]; count[2] = sizes[2]; /* loop across all files and voxels */ Rprintf("In slice \n"); for (v0=0; v0 < sizes[0]; v0++) { start[0] = v0; for (i=0; i < num_files; i++) { if (miget_real_value_hyperslab(hvol[i], MI_TYPE_DOUBLE, (misize_t *) start, (misize_t *) count, full_buffer[i]) ) error("Error opening buffer.\n"); } /* get mask - if desired */ if (xhave_mask[0] == 1) { if (miget_real_value_hyperslab(hmask, MI_TYPE_DOUBLE, (misize_t *) start, (misize_t *) count, mask_buffer) ) error("Error opening mask buffer.\n"); } Rprintf(" %d ", v0); for (v1=0; v1 < sizes[1]; v1++) { for (v2=0; v2 < sizes[2]; v2++) { output_index = v0*sizes[1]*sizes[2]+v1*sizes[2]+v2; buffer_index = sizes[2] * v1 + v2; /* only perform operation if not masked */ if(xhave_mask[0] == 0 || (xhave_mask[0] == 1 && mask_buffer[buffer_index] > xmask_value[0] -0.5 && mask_buffer[buffer_index] < xmask_value[0] + 0.5)) { for (i=0; i < num_files; i++) { // location[0] = v0; // location[1] = v1; // location[2] = v2; //SET_VECTOR_ELT(buffer, i, full_buffer[i][index]); //result = miget_real_value(hvol[i], location, 3, &xbuffer[i]); xbuffer[i] = full_buffer[i][buffer_index]; //Rprintf("V%i: %f\n", i, full_buffer[i][index]); } /* install the variable "x" into environment */ defineVar(install("x"), buffer, rho); //SETCADDR(R_fcall, buffer); //SET_VECTOR_ELT(output, index, eval(R_fcall, rho)); //SET_VECTOR_ELT(output, index, test); /* evaluate the function */ xoutput[output_index] = REAL(eval(fn, rho))[0]; } else { xoutput[output_index] = 0; } } } } Rprintf("\nDone\n"); /* free memory */ for (i=0; i<num_files; i++) { miclose_volume(hvol[i]); free(full_buffer[i]); } free(full_buffer); UNPROTECT(2); /* return the results */ return(output); }
static void fmingr(int n, double *p, double *df, void *ex) { SEXP s, x; int i; double val1, val2, eps, epsused, tmp; OptStruct OS = (OptStruct) ex; PROTECT_INDEX ipx; if (!isNull(OS->R_gcall)) { /* analytical derivatives */ PROTECT(x = allocVector(REALSXP, n)); if(!isNull(OS->names)) setAttrib(x, R_NamesSymbol, OS->names); for (i = 0; i < n; i++) { if (!R_FINITE(p[i])) error(_("non-finite value supplied by optim")); REAL(x)[i] = p[i] * (OS->parscale[i]); } SETCADR(OS->R_gcall, x); PROTECT_WITH_INDEX(s = eval(OS->R_gcall, OS->R_env), &ipx); REPROTECT(s = coerceVector(s, REALSXP), ipx); if(LENGTH(s) != n) error(_("gradient in optim evaluated to length %d not %d"), LENGTH(s), n); for (i = 0; i < n; i++) df[i] = REAL(s)[i] * (OS->parscale[i])/(OS->fnscale); UNPROTECT(2); } else { /* numerical derivatives */ PROTECT(x = allocVector(REALSXP, n)); setAttrib(x, R_NamesSymbol, OS->names); SET_NAMED(x, 2); // in case f tries to change it for (i = 0; i < n; i++) REAL(x)[i] = p[i] * (OS->parscale[i]); SETCADR(OS->R_fcall, x); if(OS->usebounds == 0) { for (i = 0; i < n; i++) { eps = OS->ndeps[i]; REAL(x)[i] = (p[i] + eps) * (OS->parscale[i]); PROTECT_WITH_INDEX(s = eval(OS->R_fcall, OS->R_env), &ipx); REPROTECT(s = coerceVector(s, REALSXP), ipx); val1 = REAL(s)[0]/(OS->fnscale); REAL(x)[i] = (p[i] - eps) * (OS->parscale[i]); REPROTECT(s = eval(OS->R_fcall, OS->R_env), ipx); REPROTECT(s = coerceVector(s, REALSXP), ipx); val2 = REAL(s)[0]/(OS->fnscale); df[i] = (val1 - val2)/(2 * eps); if(!R_FINITE(df[i])) error(("non-finite finite-difference value [%d]"), i+1); REAL(x)[i] = p[i] * (OS->parscale[i]); UNPROTECT(1); } } else { /* usebounds */ for (i = 0; i < n; i++) { epsused = eps = OS->ndeps[i]; tmp = p[i] + eps; if (tmp > OS->upper[i]) { tmp = OS->upper[i]; epsused = tmp - p[i]; } REAL(x)[i] = tmp * (OS->parscale[i]); PROTECT_WITH_INDEX(s = eval(OS->R_fcall, OS->R_env), &ipx); REPROTECT(s = coerceVector(s, REALSXP), ipx); val1 = REAL(s)[0]/(OS->fnscale); tmp = p[i] - eps; if (tmp < OS->lower[i]) { tmp = OS->lower[i]; eps = p[i] - tmp; } REAL(x)[i] = tmp * (OS->parscale[i]); REPROTECT(s = eval(OS->R_fcall, OS->R_env), ipx); REPROTECT(s = coerceVector(s, REALSXP), ipx); val2 = REAL(s)[0]/(OS->fnscale); df[i] = (val1 - val2)/(epsused + eps); if(!R_FINITE(df[i])) error(("non-finite finite-difference value [%d]"), i+1); REAL(x)[i] = p[i] * (OS->parscale[i]); UNPROTECT(1); } } UNPROTECT(1); /* x */ } }
SEXP gridLCM( SEXP Rptr){ SEXP ans= PROTECT( allocVector(INTSXP,1) ); ElGridLCM( toGrid(Rptr), INTEGER(ans) ); UNPROTECT(1); return ans; }
SEXP get_txt_data(SEXP directory, SEXP coverage, SEXP filename) { int i,j,n; int **idata; double *x, *y; char pathtofile[PATH]; AVCTxt *reg; AVCBinFile *file; SEXP *table, points,aux; strcpy(pathtofile, CHAR(STRING_ELT(directory,0))); complete_path(pathtofile, (char *) CHAR(STRING_ELT(coverage,0)), 1);/*FIXME*/ if(!(file=AVCBinReadOpen(pathtofile,CHAR(STRING_ELT(filename,0)), AVCFileTXT))) error("Error opening file"); n=0; while(AVCBinReadNextTxt(file)){n++;} Rprintf("Number of TxT ANNOTATIONS:%d\n",n); table=calloc(6, sizeof(SEXP)); idata=calloc(5, sizeof(int *)); PROTECT(table[0]=NEW_INTEGER(n));/*nTxtId*/ idata[0]=INTEGER(table[0]); PROTECT(table[1]=NEW_INTEGER(n));/*nUserId*/ idata[1]=INTEGER(table[1]); PROTECT(table[2]=NEW_INTEGER(n));/*nLevel*/ idata[2]=INTEGER(table[2]); PROTECT(table[3]=NEW_INTEGER(n));/*numVerticesLine*/ idata[3]=INTEGER(table[3]); PROTECT(table[4]=NEW_INTEGER(n));/*numVerticesArrow*/ idata[4]=INTEGER(table[4]); PROTECT(table[5]=NEW_STRING(n));/*Character strings*/ PROTECT(points=NEW_LIST(n)); if(AVCBinReadRewind(file)) error("Rewind"); for(i=0;i<n;i++) { if(!(reg=(AVCTxt*)AVCBinReadNextTxt(file))) error("Error while reading register"); ((int *)idata[0])[i]=reg->nTxtId; ((int *)idata[1])[i]=reg->nUserId; ((int *)idata[2])[i]=reg->nLevel; ((int *)idata[3])[i]=reg->numVerticesLine; ((int *)idata[4])[i]=reg->numVerticesArrow; SET_STRING_ELT(table[5],i, COPY_TO_USER_STRING(reg->pszText)); SET_VECTOR_ELT(points, i, NEW_LIST(2)); aux=VECTOR_ELT(points, i); /*This can be improved storing only the right numnber of vertices*/ SET_VECTOR_ELT(aux, 0, NEW_NUMERIC(4)); x=REAL(VECTOR_ELT(aux,0)); SET_VECTOR_ELT(aux, 1, NEW_NUMERIC(4)); y=REAL(VECTOR_ELT(aux,1)); for(j=0;j<4;j++) { x[j]=reg->pasVertices[j].x; y[j]=reg->pasVertices[j].y; } } PROTECT(aux=NEW_LIST(7)); for(i=0;i<6;i++) SET_VECTOR_ELT(aux, i, table[i]); SET_VECTOR_ELT(aux, i, points); UNPROTECT(8); free(table); free(idata); return aux; }
/* par fn gr method options */ SEXP optim(SEXP call, SEXP op, SEXP args, SEXP rho) { SEXP par, fn, gr, method, options, tmp, slower, supper; SEXP res, value, counts, conv; int i, npar=0, *mask, trace, maxit, fncount = 0, grcount = 0, nREPORT, tmax; int ifail = 0; double *dpar, *opar, val = 0.0, abstol, reltol, temp; const char *tn; OptStruct OS; PROTECT_INDEX par_index; args = CDR(args); OS = (OptStruct) R_alloc(1, sizeof(opt_struct)); OS->usebounds = 0; OS->R_env = rho; par = CAR(args); OS->names = getAttrib(par, R_NamesSymbol); args = CDR(args); fn = CAR(args); if (!isFunction(fn)) error(_("'fn' is not a function")); args = CDR(args); gr = CAR(args); args = CDR(args); method = CAR(args); if (!isString(method)|| LENGTH(method) != 1) error(_("invalid '%s' argument"), "method"); tn = CHAR(STRING_ELT(method, 0)); args = CDR(args); options = CAR(args); PROTECT(OS->R_fcall = lang2(fn, R_NilValue)); PROTECT_WITH_INDEX(par = coerceVector(par, REALSXP), &par_index); if (MAYBE_REFERENCED(par)) REPROTECT(par = duplicate(par), par_index); npar = LENGTH(par); dpar = vect(npar); opar = vect(npar); trace = asInteger(getListElement(options, "trace")); OS->fnscale = asReal(getListElement(options, "fnscale")); tmp = getListElement(options, "parscale"); if (LENGTH(tmp) != npar) error(_("'parscale' is of the wrong length")); PROTECT(tmp = coerceVector(tmp, REALSXP)); OS->parscale = vect(npar); for (i = 0; i < npar; i++) OS->parscale[i] = REAL(tmp)[i]; UNPROTECT(1); for (i = 0; i < npar; i++) dpar[i] = REAL(par)[i] / (OS->parscale[i]); PROTECT(res = allocVector(VECSXP, 5)); SEXP names; PROTECT(names = allocVector(STRSXP, 5)); SET_STRING_ELT(names, 0, mkChar("par")); SET_STRING_ELT(names, 1, mkChar("value")); SET_STRING_ELT(names, 2, mkChar("counts")); SET_STRING_ELT(names, 3, mkChar("convergence")); SET_STRING_ELT(names, 4, mkChar("message")); setAttrib(res, R_NamesSymbol, names); UNPROTECT(1); PROTECT(value = allocVector(REALSXP, 1)); PROTECT(counts = allocVector(INTSXP, 2)); SEXP countnames; PROTECT(countnames = allocVector(STRSXP, 2)); SET_STRING_ELT(countnames, 0, mkChar("function")); SET_STRING_ELT(countnames, 1, mkChar("gradient")); setAttrib(counts, R_NamesSymbol, countnames); UNPROTECT(1); PROTECT(conv = allocVector(INTSXP, 1)); abstol = asReal(getListElement(options, "abstol")); reltol = asReal(getListElement(options, "reltol")); maxit = asInteger(getListElement(options, "maxit")); if (maxit == NA_INTEGER) error(_("'maxit' is not an integer")); if (strcmp(tn, "Nelder-Mead") == 0) { double alpha, beta, gamm; alpha = asReal(getListElement(options, "alpha")); beta = asReal(getListElement(options, "beta")); gamm = asReal(getListElement(options, "gamma")); nmmin(npar, dpar, opar, &val, fminfn, &ifail, abstol, reltol, (void *)OS, alpha, beta, gamm, trace, &fncount, maxit); for (i = 0; i < npar; i++) REAL(par)[i] = opar[i] * (OS->parscale[i]); grcount = NA_INTEGER; } else if (strcmp(tn, "SANN") == 0) { tmax = asInteger(getListElement(options, "tmax")); temp = asReal(getListElement(options, "temp")); if (trace) trace = asInteger(getListElement(options, "REPORT")); if (tmax == NA_INTEGER || tmax < 1) // PR#15194 error(_("'tmax' is not a positive integer")); if (!isNull(gr)) { if (!isFunction(gr)) error(_("'gr' is not a function")); PROTECT(OS->R_gcall = lang2(gr, R_NilValue)); } else { PROTECT(OS->R_gcall = R_NilValue); /* for balance */ } samin (npar, dpar, &val, fminfn, maxit, tmax, temp, trace, (void *)OS); for (i = 0; i < npar; i++) REAL(par)[i] = dpar[i] * (OS->parscale[i]); fncount = npar > 0 ? maxit : 1; grcount = NA_INTEGER; UNPROTECT(1); /* OS->R_gcall */ } else if (strcmp(tn, "BFGS") == 0) { SEXP ndeps; nREPORT = asInteger(getListElement(options, "REPORT")); if (!isNull(gr)) { if (!isFunction(gr)) error(_("'gr' is not a function")); PROTECT(OS->R_gcall = lang2(gr, R_NilValue)); } else { PROTECT(OS->R_gcall = R_NilValue); /* for balance */ ndeps = getListElement(options, "ndeps"); if (LENGTH(ndeps) != npar) error(_("'ndeps' is of the wrong length")); OS->ndeps = vect(npar); PROTECT(ndeps = coerceVector(ndeps, REALSXP)); for (i = 0; i < npar; i++) OS->ndeps[i] = REAL(ndeps)[i]; UNPROTECT(1); } mask = (int *) R_alloc(npar, sizeof(int)); for (i = 0; i < npar; i++) mask[i] = 1; vmmin(npar, dpar, &val, fminfn, fmingr, maxit, trace, mask, abstol, reltol, nREPORT, (void *)OS, &fncount, &grcount, &ifail); for (i = 0; i < npar; i++) REAL(par)[i] = dpar[i] * (OS->parscale[i]); UNPROTECT(1); /* OS->R_gcall */ } else if (strcmp(tn, "CG") == 0) { int type; SEXP ndeps; type = asInteger(getListElement(options, "type")); if (!isNull(gr)) { if (!isFunction(gr)) error(_("'gr' is not a function")); PROTECT(OS->R_gcall = lang2(gr, R_NilValue)); } else { PROTECT(OS->R_gcall = R_NilValue); /* for balance */ ndeps = getListElement(options, "ndeps"); if (LENGTH(ndeps) != npar) error(_("'ndeps' is of the wrong length")); OS->ndeps = vect(npar); PROTECT(ndeps = coerceVector(ndeps, REALSXP)); for (i = 0; i < npar; i++) OS->ndeps[i] = REAL(ndeps)[i]; UNPROTECT(1); } cgmin(npar, dpar, opar, &val, fminfn, fmingr, &ifail, abstol, reltol, (void *)OS, type, trace, &fncount, &grcount, maxit); for (i = 0; i < npar; i++) REAL(par)[i] = opar[i] * (OS->parscale[i]); UNPROTECT(1); /* OS->R_gcall */ } else if (strcmp(tn, "L-BFGS-B") == 0) { SEXP ndeps, smsg; double *lower = vect(npar), *upper = vect(npar); int lmm, *nbd = (int *) R_alloc(npar, sizeof(int)); double factr, pgtol; char msg[60]; nREPORT = asInteger(getListElement(options, "REPORT")); factr = asReal(getListElement(options, "factr")); pgtol = asReal(getListElement(options, "pgtol")); lmm = asInteger(getListElement(options, "lmm")); if (!isNull(gr)) { if (!isFunction(gr)) error(_("'gr' is not a function")); PROTECT(OS->R_gcall = lang2(gr, R_NilValue)); } else { PROTECT(OS->R_gcall = R_NilValue); /* for balance */ ndeps = getListElement(options, "ndeps"); if (LENGTH(ndeps) != npar) error(_("'ndeps' is of the wrong length")); OS->ndeps = vect(npar); PROTECT(ndeps = coerceVector(ndeps, REALSXP)); for (i = 0; i < npar; i++) OS->ndeps[i] = REAL(ndeps)[i]; UNPROTECT(1); } args = CDR(args); slower = CAR(args); /* coerce in calling code */ args = CDR(args); supper = CAR(args); for (i = 0; i < npar; i++) { lower[i] = REAL(slower)[i] / (OS->parscale[i]); upper[i] = REAL(supper)[i] / (OS->parscale[i]); if (!R_FINITE(lower[i])) { if (!R_FINITE(upper[i])) nbd[i] = 0; else nbd[i] = 3; } else { if (!R_FINITE(upper[i])) nbd[i] = 1; else nbd[i] = 2; } } OS->usebounds = 1; OS->lower = lower; OS->upper = upper; lbfgsb(npar, lmm, dpar, lower, upper, nbd, &val, fminfn, fmingr, &ifail, (void *)OS, factr, pgtol, &fncount, &grcount, maxit, msg, trace, nREPORT); for (i = 0; i < npar; i++) REAL(par)[i] = dpar[i] * (OS->parscale[i]); UNPROTECT(1); /* OS->R_gcall */ PROTECT(smsg = mkString(msg)); SET_VECTOR_ELT(res, 4, smsg); UNPROTECT(1); } else error(_("unknown 'method'")); if(!isNull(OS->names)) setAttrib(par, R_NamesSymbol, OS->names); REAL(value)[0] = val * (OS->fnscale); SET_VECTOR_ELT(res, 0, par); SET_VECTOR_ELT(res, 1, value); INTEGER(counts)[0] = fncount; INTEGER(counts)[1] = grcount; SET_VECTOR_ELT(res, 2, counts); INTEGER(conv)[0] = ifail; SET_VECTOR_ELT(res, 3, conv); UNPROTECT(6); return res; }
/* It returns the table names and something more: - Arc file - Number of fields - Register Size - Number of registers - External/Internal Table Identifier */ SEXP get_table_names(SEXP directory) { SEXP *table, aux; AVCRawBinFile *arcfile; AVCTableDef tabledefaux; char arcdir[PATH], *dirname; int i,n, **idata; dirname= (char *) CHAR(STRING_ELT(directory,0));/*FIXME*/ strcpy(arcdir,dirname); complete_path(arcdir,"arc.dir", 0); if(!(arcfile=AVCRawBinOpen(arcdir,"r"))) { error("Error opening arc.dir"); } n=0; while(!AVCRawBinEOF(arcfile)) { if(!_AVCBinReadNextArcDir(arcfile, &tabledefaux)) n++; } AVCRawBinFSeek(arcfile, 0,SEEK_SET); table=calloc(6, sizeof(SEXP)); PROTECT(table[0]=NEW_STRING(n)); PROTECT(table[1]=NEW_STRING(n)); idata=calloc(4, sizeof(char *)); PROTECT(table[2]=NEW_INTEGER(n)); idata[0]=INTEGER(table[2]); PROTECT(table[3]=NEW_INTEGER(n)); idata[1]=INTEGER(table[3]); PROTECT(table[4]=NEW_INTEGER(n)); idata[2]=INTEGER(table[4]); PROTECT(table[5]=NEW_LOGICAL(n)); idata[3]=LOGICAL(table[5]); i=0; while(!AVCRawBinEOF(arcfile)) { if(_AVCBinReadNextArcDir(arcfile, &tabledefaux)) break; SET_STRING_ELT(table[0],i,COPY_TO_USER_STRING(tabledefaux.szTableName)); SET_STRING_ELT(table[1],i,COPY_TO_USER_STRING(tabledefaux.szInfoFile)); idata[0][i]=tabledefaux.numFields; idata[1][i]=tabledefaux.nRecSize; idata[2][i]=tabledefaux.numRecords; if(!strcmp(tabledefaux.szExternal,"XX")) idata[3][i]=1; else idata[3][i]=0; i++; } PROTECT(aux=NEW_LIST(6)); for(i=0;i<6;i++) SET_VECTOR_ELT(aux,i,table[i]); UNPROTECT(7); free(table); free(idata); return aux; }
SEXP get_lab_data(SEXP directory, SEXP coverage, SEXP filename) { int i,n; void **pdata; char pathtofile[PATH]; AVCLab *reg; AVCBinFile *file; SEXP *table,aux; strcpy(pathtofile, CHAR(STRING_ELT(directory,0))); complete_path(pathtofile, (char *) CHAR(STRING_ELT(coverage,0)),1);/*FIXME*/ if(!(file=AVCBinReadOpen(pathtofile,CHAR(STRING_ELT(filename,0)), AVCFileLAB))) error("Error opening file"); n=0; while(AVCBinReadNextLab(file)){n++;} Rprintf("Number of LABELS:%d\n",n); table=calloc(8, sizeof(SEXP)); pdata=calloc(8, sizeof(void *)); PROTECT(table[0]=NEW_INTEGER(n)); pdata[0]=INTEGER(table[0]); PROTECT(table[1]=NEW_INTEGER(n)); pdata[1]=INTEGER(table[1]); for(i=2;i<8;i++) { PROTECT(table[i]=NEW_NUMERIC(n)); pdata[i]=REAL(table[i]); } if(AVCBinReadRewind(file)) error("Rewind"); for(i=0;i<n;i++) { if(!(reg=(AVCLab*)AVCBinReadNextLab(file))) error("Error while reading register"); ((int *)pdata[0])[i]=reg->nValue; ((int *)pdata[1])[i]=reg->nPolyId; ((double*)pdata[2])[i]=reg->sCoord1.x; ((double*)pdata[3])[i]=reg->sCoord1.y; ((double*)pdata[4])[i]=reg->sCoord2.x; ((double*)pdata[5])[i]=reg->sCoord2.y; ((double*)pdata[6])[i]=reg->sCoord3.x; ((double*)pdata[7])[i]=reg->sCoord3.y; } PROTECT(aux=NEW_LIST(8)); for(i=0;i<8;i++) { SET_VECTOR_ELT(aux,i,table[i]); } UNPROTECT(9); free(table); free(pdata); return aux; }
SEXP do_subset_xts(SEXP x, SEXP sr, SEXP sc, SEXP drop) //SEXP s, SEXP call, int drop) { SEXP attr, result, dim; int nr, nc, nrs, ncs; int i, j, ii, jj, ij, iijj; int mode; int *int_x=NULL, *int_result=NULL, *int_newindex=NULL, *int_index=NULL; double *real_x=NULL, *real_result=NULL, *real_newindex=NULL, *real_index=NULL; nr = nrows(x); nc = ncols(x); if( length(x)==0 ) return x; dim = getAttrib(x, R_DimSymbol); nrs = LENGTH(sr); ncs = LENGTH(sc); int *int_sr=NULL, *int_sc=NULL; int_sr = INTEGER(sr); int_sc = INTEGER(sc); mode = TYPEOF(x); result = allocVector(mode, nrs*ncs); PROTECT(result); if( mode==INTSXP ) { int_x = INTEGER(x); int_result = INTEGER(result); } else if( mode==REALSXP ) { real_x = REAL(x); real_result = REAL(result); } /* code to handle index of xts object efficiently */ SEXP index, newindex; int indx; index = getAttrib(x, install("index")); PROTECT(index); if(TYPEOF(index) == INTSXP) { newindex = allocVector(INTSXP, LENGTH(sr)); PROTECT(newindex); int_newindex = INTEGER(newindex); int_index = INTEGER(index); for(indx = 0; indx < nrs; indx++) { int_newindex[indx] = int_index[ (int_sr[indx])-1]; } copyAttributes(index, newindex); setAttrib(result, install("index"), newindex); UNPROTECT(1); } if(TYPEOF(index) == REALSXP) { newindex = allocVector(REALSXP, LENGTH(sr)); PROTECT(newindex); real_newindex = REAL(newindex); real_index = REAL(index); for(indx = 0; indx < nrs; indx++) { real_newindex[indx] = real_index[ (int_sr[indx])-1 ]; } copyAttributes(index, newindex); setAttrib(result, install("index"), newindex); UNPROTECT(1); } for (i = 0; i < nrs; i++) { ii = int_sr[i]; if (ii != NA_INTEGER) { if (ii < 1 || ii > nr) error("i is out of range\n"); ii--; } /* Begin column loop */ for (j = 0; j < ncs; j++) { //jj = INTEGER(sc)[j]; jj = int_sc[j]; if (jj != NA_INTEGER) { if (jj < 1 || jj > nc) error("j is out of range\n"); jj--; } ij = i + j * nrs; if (ii == NA_INTEGER || jj == NA_INTEGER) { switch ( mode ) { case REALSXP: real_result[ij] = NA_REAL; break; case LGLSXP: case INTSXP: int_result[ij] = NA_INTEGER; break; case CPLXSXP: COMPLEX(result)[ij].r = NA_REAL; COMPLEX(result)[ij].i = NA_REAL; break; case STRSXP: SET_STRING_ELT(result, ij, NA_STRING); break; case VECSXP: SET_VECTOR_ELT(result, ij, R_NilValue); break; case RAWSXP: RAW(result)[ij] = (Rbyte) 0; break; default: error("xts subscripting not handled for this type"); break; } } else { iijj = ii + jj * nr; switch ( mode ) { case REALSXP: real_result[ij] = real_x[iijj]; break; case LGLSXP: LOGICAL(result)[ij] = LOGICAL(x)[iijj]; break; case INTSXP: int_result[ij] = int_x[iijj]; break; case CPLXSXP: COMPLEX(result)[ij] = COMPLEX(x)[iijj]; break; case STRSXP: SET_STRING_ELT(result, ij, STRING_ELT(x, iijj)); break; case VECSXP: SET_VECTOR_ELT(result, ij, VECTOR_ELT(x, iijj)); break; case RAWSXP: RAW(result)[ij] = RAW(x)[iijj]; break; default: error("matrix subscripting not handled for this type"); break; } } } /* end of column loop */ } /* end of row loop */ if(nrs >= 0 && ncs >= 0 && !isNull(dim)) { PROTECT(attr = allocVector(INTSXP, 2)); INTEGER(attr)[0] = nrs; INTEGER(attr)[1] = ncs; setAttrib(result, R_DimSymbol, attr); UNPROTECT(1); } /* The matrix elements have been transferred. Now we need to */ /* transfer the attributes. Most importantly, we need to subset */ /* the dimnames of the returned value. */ if (nrs >= 0 && ncs >= 0 && !isNull(dim)) { SEXP dimnames, dimnamesnames, newdimnames; dimnames = getAttrib(x, R_DimNamesSymbol); dimnamesnames = getAttrib(dimnames, R_NamesSymbol); if (!isNull(dimnames)) { PROTECT(newdimnames = allocVector(VECSXP, 2)); if (TYPEOF(dimnames) == VECSXP) { SET_VECTOR_ELT(newdimnames, 0, xtsExtractSubset(VECTOR_ELT(dimnames, 0), allocVector(STRSXP, nrs), sr)); SET_VECTOR_ELT(newdimnames, 1, xtsExtractSubset(VECTOR_ELT(dimnames, 1), allocVector(STRSXP, ncs), sc)); } else { SET_VECTOR_ELT(newdimnames, 0, xtsExtractSubset(CAR(dimnames), allocVector(STRSXP, nrs), sr)); SET_VECTOR_ELT(newdimnames, 1, xtsExtractSubset(CADR(dimnames), allocVector(STRSXP, ncs), sc)); } setAttrib(newdimnames, R_NamesSymbol, dimnamesnames); setAttrib(result, R_DimNamesSymbol, newdimnames); UNPROTECT(1); } } copyAttributes(x, result); if(ncs == 1 && LOGICAL(drop)[0]) setAttrib(result, R_DimSymbol, R_NilValue); UNPROTECT(2); return result; }
virtual ~RObject() throw() { if(is_R) { UNPROTECT(1); } }
SEXP mat_split(SEXP s, SEXP sSep, SEXP sNamesSep, SEXP sResilient, SEXP sNcol, SEXP sWhat, SEXP sSkip, SEXP sNlines) { unsigned int ncol = 1, nrow, np = 0, i, N, resilient = asInteger(sResilient); int use_ncol = asInteger(sNcol); int nsep = -1; int skip = INTEGER(sSkip)[0]; int nlines = INTEGER(sNlines)[0]; int len; SEXP res, rnam, zerochar = 0; char sep; char num_buf[48]; double * res_ptr; const char *c, *sraw, *send, *l, *le;; /* parse sep input */ if (TYPEOF(sNamesSep) == STRSXP && LENGTH(sNamesSep) > 0) nsep = (int) (unsigned char) *CHAR(STRING_ELT(sNamesSep, 0)); if (TYPEOF(sSep) != STRSXP || LENGTH(sSep) < 1) Rf_error("invalid separator"); sep = CHAR(STRING_ELT(sSep, 0))[0]; /* check the input data */ if (TYPEOF(s) == RAWSXP) { nrow = (nlines >= 0) ? count_lines_bounded(s, nlines + skip) : count_lines(s); sraw = (const char*) RAW(s); send = sraw + XLENGTH(s); if (nrow >= skip) { nrow = nrow - skip; for (i = 0; i < skip; i++) sraw = memchr(sraw,'\n',XLENGTH(s)) + 1; } else { nrow = 0; sraw = send; } } else if (TYPEOF(s) == STRSXP) { nrow = LENGTH(s); if (nrow >= skip) { nrow -= skip; } else { skip = nrow; nrow = 0; } } else { Rf_error("invalid input to split - must be a raw or character vector"); } if (nlines >= 0 && nrow > nlines) nrow = nlines; /* If no rows left, return an empty matrix */ if (!nrow) { if (np) UNPROTECT(np); return allocMatrix(TYPEOF(sWhat), 0, 0); } /* count number of columns */ if (use_ncol < 1) { if (TYPEOF(s) == RAWSXP) { ncol = 1; c = sraw; le = memchr(sraw, '\n', send - sraw); while ((c = memchr(c, (unsigned char) sep, le - c))) { ncol++; c++; } } else { c = CHAR(STRING_ELT(s, 0)); while ((c = strchr(c, sep))) { ncol++; c++; } /* if sep and nsep are the same then the first "column" is the key and not the column */ if (nsep == (int) (unsigned char) sep) ncol--; } } else ncol = use_ncol; /* allocate space for the result */ N = ncol * nrow; switch(TYPEOF(sWhat)) { case LGLSXP: case INTSXP: case REALSXP: case CPLXSXP: case STRSXP: case RAWSXP: res = PROTECT(allocMatrix(TYPEOF(sWhat), nrow, ncol)); break; default: Rf_error("Unsupported input to what."); break; } if (nsep >= 0) { SEXP dn; setAttrib(res, R_DimNamesSymbol, (dn = allocVector(VECSXP, 2))); SET_VECTOR_ELT(dn, 0, (rnam = allocVector(STRSXP, nrow))); } np++; /* cycle over the rows and parse the data */ for (i = 0; i < nrow; i++) { int j = i; /* find the row of data */ if (TYPEOF(s) == RAWSXP) { l = sraw; le = memchr(l, '\n', send - l); if (!le) le = send; sraw = le + 1; } else { l = CHAR(STRING_ELT(s, i + skip)); le = l + strlen(l); } /* if nsep, load rowname */ if (nsep >= 0) { c = memchr(l, nsep, le - l); if (c) { SET_STRING_ELT(rnam, i, Rf_mkCharLen(l, c - l)); l = c + 1; } else SET_STRING_ELT(rnam, i, R_BlankString); } /* now split the row into elements */ while (l < le) { if (!(c = memchr(l, sep, le - l))) c = le; if (j >= N) { if (resilient) break; Rf_error("line %lu: too many columns (expected %u)", (unsigned long)(i + 1), ncol); } switch(TYPEOF(sWhat)) { case LGLSXP: len = (int) (c - l); if (len > sizeof(num_buf) - 1) len = sizeof(num_buf) - 1; memcpy(num_buf, l, len); num_buf[len] = 0; int tr = StringTrue(num_buf), fa = StringFalse(num_buf); LOGICAL(res)[j] = (tr || fa) ? tr : NA_INTEGER; break; case INTSXP: len = (int) (c - l); /* watch for overflow and truncate -- should we warn? */ if (len > sizeof(num_buf) - 1) len = sizeof(num_buf) - 1; memcpy(num_buf, l, len); num_buf[len] = 0; INTEGER(res)[j] = Strtoi(num_buf, 10); break; case REALSXP: len = (int) (c - l); /* watch for overflow and truncate -- should we warn? */ if (len > sizeof(num_buf) - 1) len = sizeof(num_buf) - 1; memcpy(num_buf, l, len); num_buf[len] = 0; REAL(res)[j] = R_atof(num_buf); break; case CPLXSXP: len = (int) (c - l); /* watch for overflow and truncate -- should we warn? */ if (len > sizeof(num_buf) - 1) len = sizeof(num_buf) - 1; memcpy(num_buf, l, len); num_buf[len] = 0; COMPLEX(res)[j] = strtoc(num_buf, TRUE); break; case STRSXP: SET_STRING_ELT(res, j, Rf_mkCharLen(l, c - l)); break; case RAWSXP: len = (int) (c - l); /* watch for overflow and truncate -- should we warn? */ if (len > sizeof(num_buf) - 1) len = sizeof(num_buf) - 1; memcpy(num_buf, l, len); num_buf[len] = 0; RAW(res)[j] = strtoraw(num_buf); break; } l = c + 1; j += nrow; } /* fill up unused columns with NAs */ while (j < N) { switch (TYPEOF(sWhat)) { case LGLSXP: LOGICAL(res)[j] = NA_INTEGER; break; case INTSXP: INTEGER(res)[j] = NA_INTEGER; break; case REALSXP: REAL(res)[j] = NA_REAL; break; case CPLXSXP: COMPLEX(res)[j].r = NA_REAL; COMPLEX(res)[j].i = NA_REAL; break; case STRSXP: SET_STRING_ELT(res, j, R_NaString); break; case RAWSXP: RAW(res)[j] = (Rbyte) 0; break; } j += nrow; } } UNPROTECT(np); return res; }
SEXP spPPGLM(SEXP Y_r, SEXP X_r, SEXP p_r, SEXP n_r, SEXP family_r, SEXP weights_r, SEXP m_r, SEXP knotsD_r, SEXP knotsCoordsD_r, SEXP betaPrior_r, SEXP betaNorm_r, SEXP sigmaSqIG_r, SEXP nuUnif_r, SEXP phiUnif_r, SEXP phiStarting_r, SEXP sigmaSqStarting_r, SEXP nuStarting_r, SEXP betaStarting_r, SEXP w_strStarting_r, SEXP phiTuning_r, SEXP sigmaSqTuning_r, SEXP nuTuning_r, SEXP betaTuning_r, SEXP w_strTuning_r, SEXP covModel_r, SEXP nSamples_r, SEXP verbose_r, SEXP nReport_r){ /***************************************** Common variables *****************************************/ int i,j,k,l,info,nProtect= 0; char const *lower = "L"; char const *upper = "U"; char const *ntran = "N"; char const *ytran = "T"; char const *rside = "R"; char const *lside = "L"; const double one = 1.0; const double negOne = -1.0; const double zero = 0.0; const int incOne = 1; /***************************************** Set-up *****************************************/ double *Y = REAL(Y_r); double *X = REAL(X_r); int p = INTEGER(p_r)[0]; int pp = p*p; int n = INTEGER(n_r)[0]; std::string family = CHAR(STRING_ELT(family_r,0)); int *weights = INTEGER(weights_r); //covariance model std::string covModel = CHAR(STRING_ELT(covModel_r,0)); int m = INTEGER(m_r)[0]; double *knotsD = REAL(knotsD_r); double *knotsCoordsD = REAL(knotsCoordsD_r); //priors and starting std::string betaPrior = CHAR(STRING_ELT(betaPrior_r,0)); double *betaMu = NULL; double *betaSd = NULL; if(betaPrior == "normal"){ betaMu = REAL(VECTOR_ELT(betaNorm_r, 0)); betaSd = REAL(VECTOR_ELT(betaNorm_r, 1)); } double *sigmaSqIG = REAL(sigmaSqIG_r); double *phiUnif = REAL(phiUnif_r); double phiStarting = REAL(phiStarting_r)[0]; double sigmaSqStarting = REAL(sigmaSqStarting_r)[0]; double *betaStarting = REAL(betaStarting_r); double *w_strStarting = REAL(w_strStarting_r); double sigmaSqIGa = sigmaSqIG[0]; double sigmaSqIGb = sigmaSqIG[1]; double phiUnifa = phiUnif[0]; double phiUnifb = phiUnif[1]; //if matern double *nuUnif = NULL; double nuStarting = 0; double nuUnifa = 0, nuUnifb = 0; if(covModel == "matern"){ nuUnif = REAL(nuUnif_r); nuStarting = REAL(nuStarting_r)[0]; nuUnifa = nuUnif[0]; nuUnifb = nuUnif[1]; } //tuning double *betaTuning = (double *) R_alloc(p*p, sizeof(double)); F77_NAME(dcopy)(&pp, REAL(betaTuning_r), &incOne, betaTuning, &incOne); double phiTuning = sqrt(REAL(phiTuning_r)[0]); double sigmaSqTuning = sqrt(REAL(sigmaSqTuning_r)[0]); double *w_strTuning = REAL(w_strTuning_r); double nuTuning = 0; if(covModel == "matern") nuTuning = sqrt(REAL(nuTuning_r)[0]); int nSamples = INTEGER(nSamples_r)[0]; int verbose = INTEGER(verbose_r)[0]; int nReport = INTEGER(nReport_r)[0]; if(verbose){ Rprintf("----------------------------------------\n"); Rprintf("\tGeneral model description\n"); Rprintf("----------------------------------------\n"); Rprintf("Model fit with %i observations.\n\n", n); Rprintf("Number of covariates %i (including intercept if specified).\n\n", p); Rprintf("Using the %s spatial correlation model.\n\n", covModel.c_str()); Rprintf("Using non-modified predictive process with %i knots.\n\n", m); Rprintf("Number of MCMC samples %i.\n\n", nSamples); Rprintf("Priors and hyperpriors:\n"); if(betaPrior == "flat"){ Rprintf("\tbeta flat.\n"); }else{ Rprintf("\tbeta normal:\n"); Rprintf("\t\tmu:"); printVec(betaMu, p); Rprintf("\t\tsd:"); printVec(betaSd, p);Rprintf("\n"); } Rprintf("\n"); Rprintf("\tsigma.sq IG hyperpriors shape=%.5f and scale=%.5f\n", sigmaSqIGa, sigmaSqIGb); Rprintf("\n"); Rprintf("\tphi Unif hyperpriors a=%.5f and b=%.5f\n", phiUnifa, phiUnifb); Rprintf("\n"); if(covModel == "matern"){ Rprintf("\tnu Unif hyperpriors a=%.5f and b=%.5f\n", nuUnifa, nuUnifb); } Rprintf("Metropolis tuning values:\n"); Rprintf("\tbeta tuning:\n"); printMtrx(betaTuning, p, p); Rprintf("\n"); Rprintf("\tsigma.sq tuning: %.5f\n", sigmaSqTuning); Rprintf("\n"); Rprintf("\tphi tuning: %.5f\n", phiTuning); Rprintf("\n"); if(covModel == "matern"){ Rprintf("\tnu tuning: %.5f\n", nuTuning); Rprintf("\n"); } Rprintf("Metropolis starting values:\n"); Rprintf("\tbeta starting:\n"); Rprintf("\t"); printVec(betaStarting, p); Rprintf("\n"); Rprintf("\tsigma.sq starting: %.5f\n", sigmaSqStarting); Rprintf("\n"); Rprintf("\tphi starting: %.5f\n", phiStarting); Rprintf("\n"); if(covModel == "matern"){ Rprintf("\tnu starting: %.5f\n", nuStarting); Rprintf("\n"); } } /***************************************** Set-up MCMC sample matrices etc. *****************************************/ int nn = n*n, nm = n*m, mm = m*m; //spatial parameters int nParams, betaIndx, sigmaSqIndx, phiIndx, nuIndx; if(covModel != "matern"){ nParams = p+2;//sigma^2, phi betaIndx = 0; sigmaSqIndx = betaIndx+p; phiIndx = sigmaSqIndx+1; }else{ nParams = p+3;//sigma^2, phi, nu betaIndx = 0; sigmaSqIndx = betaIndx+p; phiIndx = sigmaSqIndx+1; nuIndx = phiIndx+1; } double *spParams = (double *) R_alloc(nParams, sizeof(double)); //set starting F77_NAME(dcopy)(&p, betaStarting, &incOne, &spParams[betaIndx], &incOne); spParams[sigmaSqIndx] = log(sigmaSqStarting); spParams[phiIndx] = logit(phiStarting, phiUnifa, phiUnifb); if(covModel == "matern") spParams[nuIndx] = logit(nuStarting, nuUnifa, nuUnifb); double *wCurrent = (double *) R_alloc(n, sizeof(double)); double *w_strCurrent = (double *) R_alloc(m, sizeof(double)); F77_NAME(dcopy)(&m, w_strStarting, &incOne, w_strCurrent, &incOne); //samples and random effects SEXP w_r, w_str_r, samples_r, accept_r; PROTECT(w_r = allocMatrix(REALSXP, n, nSamples)); nProtect++; double *w = REAL(w_r); zeros(w, n*nSamples); PROTECT(w_str_r = allocMatrix(REALSXP, m, nSamples)); nProtect++; double *w_str = REAL(w_str_r); zeros(w_str, m*nSamples); PROTECT(samples_r = allocMatrix(REALSXP, nParams, nSamples)); nProtect++; double *samples = REAL(samples_r); PROTECT(accept_r = allocMatrix(REALSXP, 1, 1)); nProtect++; /***************************************** Set-up MCMC alg. vars. matrices etc. *****************************************/ int s=0, status=0, rtnStatus=0, accept=0, batchAccept = 0; double logPostCurrent = 0, logPostCand = 0, detCand = 0; double *P = (double *) R_alloc(nm, sizeof(double)); double *K = (double *) R_alloc(mm, sizeof(double)); double *tmp_n = (double *) R_alloc(n, sizeof(double)); double *tmp_m = (double *) R_alloc(m, sizeof(double)); double *tmp_nm = (double *) R_alloc(nm, sizeof(double)); double *theta = (double *) R_alloc(3, sizeof(double)); //phi, nu, and perhaps more in the future double *candSpParams = (double *) R_alloc(nParams, sizeof(double)); double *w_strCand = (double *) R_alloc(m, sizeof(double)); double *wCand = (double *) R_alloc(n, sizeof(double)); double sigmaSq, phi, nu; double *beta = (double *) R_alloc(p, sizeof(double)); double logMHRatio; if(verbose){ Rprintf("-------------------------------------------------\n"); Rprintf("\t\tSampling\n"); Rprintf("-------------------------------------------------\n"); #ifdef Win32 R_FlushConsole(); #endif } logPostCurrent = R_NegInf; GetRNGstate(); for(s = 0; s < nSamples; s++){ //propose mvrnorm(&candSpParams[betaIndx], &spParams[betaIndx], betaTuning, p, false); F77_NAME(dcopy)(&p, &candSpParams[betaIndx], &incOne, beta, &incOne); candSpParams[sigmaSqIndx] = rnorm(spParams[sigmaSqIndx], sigmaSqTuning); sigmaSq = theta[0] = exp(candSpParams[sigmaSqIndx]); candSpParams[phiIndx] = rnorm(spParams[phiIndx], phiTuning); phi = theta[1] = logitInv(candSpParams[phiIndx], phiUnifa, phiUnifb); if(covModel == "matern"){ candSpParams[nuIndx] = rnorm(spParams[nuIndx], nuTuning); nu = theta[2] = logitInv(candSpParams[nuIndx], nuUnifa, nuUnifb); } for(i = 0; i < m; i++){ w_strCand[i] = rnorm(w_strCurrent[i], sqrt(w_strTuning[i])); } //construct covariance matrices spCovLT(knotsD, m, theta, covModel, K); spCov(knotsCoordsD, nm, theta, covModel, P); //invert C and log det cov detCand = 0; F77_NAME(dpotrf)(lower, &m, K, &m, &info); if(info != 0){error("c++ error: Cholesky failed in spGLM\n");} for(i = 0; i < m; i++) detCand += 2*log(K[i*m+i]); F77_NAME(dpotri)(lower, &m, K, &m, &info); if(info != 0){error("c++ error: Cholesky inverse failed in spGLM\n");} //make \tild{w} F77_NAME(dsymv)(lower, &m, &one, K, &m, w_strCand, &incOne, &zero, tmp_m, &incOne); F77_NAME(dgemv)(ytran, &m, &n, &one, P, &m, tmp_m, &incOne, &zero, wCand, &incOne); //Likelihood with Jacobian logPostCand = 0.0; if(betaPrior == "normal"){ for(i = 0; i < p; i++){ logPostCand += dnorm(beta[i], betaMu[i], betaSd[i], 1); } } logPostCand += -1.0*(1.0+sigmaSqIGa)*log(sigmaSq)-sigmaSqIGb/sigmaSq+log(sigmaSq); logPostCand += log(phi - phiUnifa) + log(phiUnifb - phi); if(covModel == "matern"){ logPostCand += log(nu - nuUnifa) + log(nuUnifb - nu); } F77_NAME(dgemv)(ntran, &n, &p, &one, X, &n, beta, &incOne, &zero, tmp_n, &incOne); if(family == "binomial"){ logPostCand += binomial_logpost(n, Y, tmp_n, wCand, weights); }else if(family == "poisson"){ logPostCand += poisson_logpost(n, Y, tmp_n, wCand, weights); }else{ error("c++ error: family misspecification in spGLM\n"); } //(-1/2) * tmp_n` * C^-1 * tmp_n logPostCand += -0.5*detCand-0.5*F77_NAME(ddot)(&m, w_strCand, &incOne, tmp_m, &incOne); // //MH accept/reject // //MH ratio with adjustment logMHRatio = logPostCand - logPostCurrent; if(runif(0.0,1.0) <= exp(logMHRatio)){ F77_NAME(dcopy)(&nParams, candSpParams, &incOne, spParams, &incOne); F77_NAME(dcopy)(&n, wCand, &incOne, wCurrent, &incOne); F77_NAME(dcopy)(&m, w_strCand, &incOne, w_strCurrent, &incOne); logPostCurrent = logPostCand; accept++; batchAccept++; } /****************************** Save samples and report *******************************/ F77_NAME(dcopy)(&nParams, spParams, &incOne, &samples[s*nParams], &incOne); F77_NAME(dcopy)(&n, wCurrent, &incOne, &w[s*n], &incOne); F77_NAME(dcopy)(&m, w_strCurrent, &incOne, &w_str[s*m], &incOne); //report if(verbose){ if(status == nReport){ Rprintf("Sampled: %i of %i, %3.2f%%\n", s, nSamples, 100.0*s/nSamples); Rprintf("Report interval Metrop. Acceptance rate: %3.2f%%\n", 100.0*batchAccept/nReport); Rprintf("Overall Metrop. Acceptance rate: %3.2f%%\n", 100.0*accept/s); Rprintf("-------------------------------------------------\n"); #ifdef Win32 R_FlushConsole(); #endif status = 0; batchAccept = 0; } } status++; R_CheckUserInterrupt(); }//end sample loop PutRNGstate(); //final status report if(verbose){ Rprintf("Sampled: %i of %i, %3.2f%%\n", s, nSamples, 100.0*s/nSamples); Rprintf("-------------------------------------------------\n"); #ifdef Win32 R_FlushConsole(); #endif } //untransform variance variables for(s = 0; s < nSamples; s++){ samples[s*nParams+sigmaSqIndx] = exp(samples[s*nParams+sigmaSqIndx]); samples[s*nParams+phiIndx] = logitInv(samples[s*nParams+phiIndx], phiUnifa, phiUnifb); if(covModel == "matern") samples[s*nParams+nuIndx] = logitInv(samples[s*nParams+nuIndx], nuUnifa, nuUnifb); } //calculate acceptance rate REAL(accept_r)[0] = 100.0*accept/s; //make return object SEXP result, resultNames; int nResultListObjs = 4; PROTECT(result = allocVector(VECSXP, nResultListObjs)); nProtect++; PROTECT(resultNames = allocVector(VECSXP, nResultListObjs)); nProtect++; //samples SET_VECTOR_ELT(result, 0, samples_r); SET_VECTOR_ELT(resultNames, 0, mkChar("p.beta.theta.samples")); SET_VECTOR_ELT(result, 1, accept_r); SET_VECTOR_ELT(resultNames, 1, mkChar("acceptance")); SET_VECTOR_ELT(result, 2, w_r); SET_VECTOR_ELT(resultNames, 2, mkChar("p.w.samples")); SET_VECTOR_ELT(result, 3, w_str_r); SET_VECTOR_ELT(resultNames, 3, mkChar("p.w.knots.samples")); namesgets(result, resultNames); //unprotect UNPROTECT(nProtect); return(result); }
SEXP R_num_to_char(SEXP x, SEXP digits, SEXP na_as_string, SEXP use_signif) { int len = length(x); int na_string = asLogical(na_as_string); int signif = asLogical(use_signif); char buf[32]; SEXP out = PROTECT(allocVector(STRSXP, len)); if(isInteger(x)){ for (int i=0; i<len; i++) { if(INTEGER(x)[i] == NA_INTEGER){ if(na_string == NA_LOGICAL){ SET_STRING_ELT(out, i, NA_STRING); } else if(na_string){ SET_STRING_ELT(out, i, mkChar("\"NA\"")); } else { SET_STRING_ELT(out, i, mkChar("null")); } } else { modp_itoa10(INTEGER(x)[i], buf); SET_STRING_ELT(out, i, mkChar(buf)); } } } else if(isReal(x)) { int precision = asInteger(digits); double * xreal = REAL(x); for (int i=0; i<len; i++) { double val = xreal[i]; if(!R_FINITE(val)){ if(na_string == NA_LOGICAL){ SET_STRING_ELT(out, i, NA_STRING); } else if(na_string){ if(ISNA(val)){ SET_STRING_ELT(out, i, mkChar("\"NA\"")); } else if(ISNAN(val)){ SET_STRING_ELT(out, i, mkChar("\"NaN\"")); } else if(val == R_PosInf){ SET_STRING_ELT(out, i, mkChar("\"Inf\"")); } else if(val == R_NegInf){ SET_STRING_ELT(out, i, mkChar("\"-Inf\"")); } else { error("Unrecognized non finite value."); } } else { SET_STRING_ELT(out, i, mkChar("null")); } } else if(precision == NA_INTEGER){ snprintf(buf, 32, "%.15g", val); SET_STRING_ELT(out, i, mkChar(buf)); } else if(signif){ //use signifant digits rather than decimal digits snprintf(buf, 32, "%.*g", (int) ceil(fmin(15, precision)), val); SET_STRING_ELT(out, i, mkChar(buf)); } else if(precision > -1 && precision < 10 && fabs(val) < 2147483647 && fabs(val) > 1e-5) { //preferred method: fast with fixed decimal digits //does not support large numbers or scientific notation modp_dtoa2(val, buf, precision); SET_STRING_ELT(out, i, mkChar(buf)); //Rprintf("Using modp_dtoa2\n"); } else { //fall back on sprintf (includes scientific notation) //limit total precision to 15 significant digits to avoid noise //funky formula is mostly to convert decimal digits into significant digits snprintf(buf, 32, "%.*g", (int) ceil(fmin(15, fmax(1, log10(val)) + precision)), val); SET_STRING_ELT(out, i, mkChar(buf)); //Rprintf("Using sprintf with precision %d digits\n",(int) ceil(fmin(15, fmax(1, log10(val)) + precision))); } } } else { error("num_to_char called with invalid object type."); } UNPROTECT(1); return out; }
/* * The following returns a R list with the following components: * currentStreams * currentLogWeights * propUniqueStreamIds */ static SEXP resamp_func_builtin_PPW (Sampler *ss, int currentPeriod, SEXP currentStreams, SEXP currentLogWeights) { ResampleContext *rc = ss->scratch_RC; int nspr = ss->nStreamsPreResamp, dpp = ss->dimPerPeriod; int ns = ss->nStreams, *sids = rc->streamIds, ii, jj, kk; int nusids, *usids = rc->uniqueStreamIds; int nComps = 0, nProtected = 0; double *ps = rc->partialSum; double sum, uu; SEXP resampCurrentStreams, resampCurrentLogWeights, resampPropUniqueStreamIds; SEXP retList, names; double *rcs, *rclw; double *scs = REAL(currentStreams); double *sclw = REAL(currentLogWeights); double *scaw = REAL(ss->SEXPCurrentAdjWeights); void *vmax = vmaxget( ); PROTECT(resampCurrentStreams = allocMatrix(REALSXP, ns, dpp)); ++nComps; ++nProtected; PROTECT(resampCurrentLogWeights = allocVector(REALSXP, ns)); ++nComps; ++nProtected; rcs = REAL(resampCurrentStreams); rclw = REAL(resampCurrentLogWeights); sampler_adjust_log_weights(nspr, sclw, scaw); ps[0] = scaw[0]; for (jj = 1; jj < nspr; ++jj) { ps[jj] = ps[jj - 1] + scaw[jj]; } sum = ps[nspr - 1]; nusids = 0; /* resample the streams with probability proportional to their * weights */ for (jj = 0; jj < ns; ++jj) { uu = runif(0, sum); for (ii = 0; ii < nspr; ++ii) { if (uu <= ps[ii]) { sids[jj] = ii; break; } } /* copying the resampled stream */ for (kk = 0; kk < dpp; ++kk) rcs[kk * ns + jj] = scs[kk * nspr + sids[jj]]; /* making the resampled logWeights = 0 */ rclw[jj] = 0; /* find the unique stream and register it */ if (utils_is_int_in_iarray(sids[jj], nusids, usids) == FALSE) { usids[nusids] = sids[jj]; ++nusids; } } rc->nUniqueStreamIds = nusids; rc->propUniqueStreamIds = nusids / ((double) nspr); PROTECT(resampPropUniqueStreamIds = allocVector(REALSXP, 1)); ++nComps; ++nProtected; REAL(resampPropUniqueStreamIds)[0] = rc->propUniqueStreamIds; PROTECT(retList = allocVector(VECSXP, nComps)); ++nProtected; PROTECT(names = allocVector(STRSXP, nComps)); ++nProtected; nComps = 0; SET_VECTOR_ELT(retList, nComps, resampCurrentStreams); SET_STRING_ELT(names, nComps, mkChar("currentStreams")); ++nComps; SET_VECTOR_ELT(retList, nComps, resampCurrentLogWeights); SET_STRING_ELT(names, nComps, mkChar("currentLogWeights")); ++nComps; SET_VECTOR_ELT(retList, nComps, resampPropUniqueStreamIds); SET_STRING_ELT(names, nComps, mkChar("propUniqueStreamIds")); setAttrib(retList, R_NamesSymbol, names); UNPROTECT(nProtected); vmaxset(vmax); return retList; }
SEXP superSubset(SEXP x, SEXP y, SEXP fuz, SEXP vo, SEXP nec) { int i, j, k, index; double *p_x, *p_incovpri, *p_vo, min, max, so = 0.0, sumx_min, sumx_max, sumpmin_min, sumpmin_max, prisum_min, prisum_max, temp1, temp2; int xrows, xcols, yrows, *p_y, *p_fuz, *p_nec; SEXP usage = PROTECT(allocVector(VECSXP, 5)); SET_VECTOR_ELT(usage, 0, x = coerceVector(x, REALSXP)); SET_VECTOR_ELT(usage, 1, y = coerceVector(y, INTSXP)); SET_VECTOR_ELT(usage, 2, fuz = coerceVector(fuz, INTSXP)); SET_VECTOR_ELT(usage, 3, vo = coerceVector(vo, REALSXP)); SET_VECTOR_ELT(usage, 4, nec = coerceVector(nec, INTSXP)); xrows = nrows(x); yrows = nrows(y); xcols = ncols(x); double copyline[xcols]; p_x = REAL(x); p_y = INTEGER(y); p_fuz = INTEGER(fuz); p_vo = REAL(vo); p_nec = INTEGER(nec); // create the list to be returned to R SEXP incovpri = PROTECT(allocMatrix(REALSXP, 6, yrows)); p_incovpri = REAL(incovpri); // sum of the outcome variable for (i = 0; i < length(vo); i++) { so += p_vo[i]; } min = 1000; max = 0; for (k = 0; k < yrows; k++) { // loop for every line of the truth table matrix sumx_min = 0; sumx_max = 0; sumpmin_min = 0; sumpmin_max = 0; prisum_min = 0; prisum_max = 0; for (i = 0; i < xrows; i++) { // loop over every line of the data matrix for (j = 0; j < xcols; j++) { // loop over each column of the data matrix copyline[j] = p_x[i + xrows * j]; index = k + yrows * j; if (p_fuz[j] == 1) { // for the fuzzy variables, invert those who have the 3k value equal to 1 ("onex3k" in R) if (p_y[index] == 1) { copyline[j] = 1 - copyline[j]; } } else { if (p_y[index] != (copyline[j] + 1)) { copyline[j] = 0; } else { copyline[j] = 1; } } if (p_y[index] != 0) { if (copyline[j] < min) { min = copyline[j]; } if (copyline[j] > max) { max = copyline[j]; } } } // end of j loop, over columns sumx_min += min; sumx_max += max; sumpmin_min += (min < p_vo[i])?min:p_vo[i]; sumpmin_max += (max < p_vo[i])?max:p_vo[i]; temp1 = (min < p_vo[i])?min:p_vo[i]; temp2 = p_nec[0]?(1 - min):(1 - p_vo[i]); prisum_min += (temp1 < temp2)?temp1:temp2; temp1 = (max < p_vo[i])?max:p_vo[i]; temp2 = 1 - max; prisum_max += (temp1 < temp2)?temp1:temp2; min = 1000; // re-initialize min and max values max = 0; } // end of i loop p_incovpri[k*6] = (sumpmin_min == 0 && sumx_min == 0)?0:(sumpmin_min/sumx_min); p_incovpri[k*6 + 1] = (sumpmin_min == 0 && so == 0)?0:(sumpmin_min/so); p_incovpri[k*6 + 2] = (sumpmin_max == 0 && sumx_max == 0)?0:(sumpmin_max/sumx_max); p_incovpri[k*6 + 3] = (sumpmin_max == 0 && so == 0)?0:(sumpmin_max/so); temp1 = sumpmin_min - prisum_min; temp2 = p_nec[0]?so:sumx_min - prisum_min; p_incovpri[k*6 + 4] = (temp1 == 0 && temp2 == 0)?0:(temp1/temp2); temp1 = sumpmin_max - prisum_max; temp2 = so - prisum_max; p_incovpri[k*6 + 5] = (temp1 == 0 && temp2 == 0)?0:(temp1/temp2); } // end of k loop UNPROTECT(2); return(incovpri); }
/* check neighbourhood sets and markov blanets for consistency.. */ SEXP bn_recovery(SEXP bn, SEXP strict, SEXP mb, SEXP filter, SEXP debug) { int i = 0, j = 0, k = 0, n = 0, counter = 0; short int *checklist = NULL, err = 0; int *debuglevel = NULL, *checkmb = NULL, *flt = INTEGER(filter); SEXP temp, temp2, nodes, elnames = NULL, fixed; /* get the names of the nodes. */ nodes = getAttrib(bn, R_NamesSymbol); n = LENGTH(nodes); /* allocate and initialize the checklist. */ checklist = allocstatus(UPTRI_MATRIX(n)); /* dereference the debug and mb parameters. */ debuglevel = LOGICAL(debug); checkmb = LOGICAL(mb); if (*debuglevel > 0) { Rprintf("----------------------------------------------------------------\n"); if (*checkmb) Rprintf("* checking consistency of markov blankets.\n"); else Rprintf("* checking consistency of neighbourhood sets.\n"); }/*THEN*/ /* scan the structure to determine the number of arcs. */ for (i = 0; i < n; i++) { if (*debuglevel > 0) Rprintf(" > checking node %s.\n", NODE(i)); /* get the entry for the (neighbours|elements of the markov blanket) of the node.*/ temp = getListElement(bn, (char *)NODE(i)); if (!(*checkmb)) temp = getListElement(temp, "nbr"); /* check each element of the array and identify which variable it corresponds to. */ for (j = 0; j < LENGTH(temp); j++) { for (k = 0; k < n; k++) { /* increment the right element of checklist. */ if (!strcmp(NODE(k), (char *)CHAR(STRING_ELT(temp, j)))) checklist[UPTRI(i + 1, k + 1, n)]++; }/*FOR*/ }/*FOR*/ }/*FOR*/ /* if A is a neighbour of B, B is a neighbour of A; therefore each entry in * the checklist array must be equal to either zero (if the corresponding * nodes are not neighbours) or two (if the corresponding nodes are neighbours). * Any other value (typically one) is caused by an incorrect (i.e. asymmetric) * neighbourhood structure. The same logic holds for the markov blankets. */ for (i = 0; i < n; i++) for (j = i; j < n; j++) { if ((checklist[UPTRI(i + 1, j + 1, n)] != 0) && (checklist[UPTRI(i + 1, j + 1, n)] != 2)) { if (*debuglevel > 0) { if (*checkmb) Rprintf("@ asymmetry in the markov blankets for %s and %s.\n", NODE(i), NODE(j)); else Rprintf("@ asymmetry in the neighbourhood sets for %s and %s.\n", NODE(i), NODE(j)); }/*THEN*/ err = 1; }/*THEN*/ }/*FOR*/ /* no need to go on if the (neighbourhood sets|markov blankets) are symmetric; * otherwise throw either an error or a warning according to the value of the * strict parameter. */ if (!err) { return bn; }/*THEN*/ else if (isTRUE(strict)) { if (*checkmb) error("markov blankets are not symmetric.\n"); else error("neighbourhood sets are not symmetric.\n"); }/*THEN*/ /* build a correct structure to return. */ PROTECT(fixed = allocVector(VECSXP, n)); setAttrib(fixed, R_NamesSymbol, nodes); if (!(*checkmb)) { /* allocate colnames. */ PROTECT(elnames = allocVector(STRSXP, 2)); SET_STRING_ELT(elnames, 0, mkChar("mb")); SET_STRING_ELT(elnames, 1, mkChar("nbr")); }/*THEN*/ for (i = 0; i < n; i++) { if (!(*checkmb)) { /* allocate the "mb" and "nbr" elements of the node. */ PROTECT(temp = allocVector(VECSXP, 2)); SET_VECTOR_ELT(fixed, i, temp); setAttrib(temp, R_NamesSymbol, elnames); /* copy the "mb" part from the old structure. */ temp2 = getListElement(bn, (char *)NODE(i)); temp2 = getListElement(temp2, "mb"); SET_VECTOR_ELT(temp, 0, temp2); }/*THEN*/ /* rescan the checklist. */ for (j = 0; j < n; j++) if (checklist[UPTRI(i + 1, j + 1, n)] >= *flt) if (i != j) counter++; /* allocate and fill the "nbr" element. */ PROTECT(temp2 = allocVector(STRSXP, counter)); for (j = 0; j < n; j++) if (checklist[UPTRI(i + 1, j + 1, n)] >= *flt) if (i != j) SET_STRING_ELT(temp2, --counter, STRING_ELT(nodes, j)); if (*checkmb) { SET_VECTOR_ELT(fixed, i, temp2); UNPROTECT(1); }/*THEN*/ else { SET_VECTOR_ELT(temp, 1, temp2); UNPROTECT(2); }/*ELSE*/ }/*FOR*/ if (*checkmb) UNPROTECT(1); else UNPROTECT(2); return fixed; }/*BN_RECOVERY*/
// m and n should be the same. This code should be updated at some point. SEXP pair_wmw_test(SEXP _X, SEXP _Y, SEXP _corr, SEXP _method, SEXP _mc_rep, SEXP _comb){ int m=length(_X); int n=length(_Y); int N=m+n; int i,b; int corr=asInteger(_corr);// 0,1,-1,2 int method=asInteger(_method);// 0,1,2,3,4 double *X0=REAL(_X), *Y0=REAL(_Y); int *comb=INTEGER(_comb); double ind; double *X = malloc(m*sizeof(double)); double *Y = malloc(n*sizeof(double)); double *xy = malloc(N*sizeof(double)); double *unique = malloc(N*sizeof(double)); int *nties = malloc(N*sizeof(int)); int mc_rep=asInteger(_mc_rep); // 0: exact perm, 1: z only, 1e4: mc int nperm=length(_comb)/m; // number of permutation SEXP _ans=PROTECT(allocVector(REALSXP, mc_rep==0?nperm:mc_rep)); double *ans=REAL(_ans); // // NTIES <- table(r) // for (i = 0; i < N; i++) nties[i]=1; // int n_unique=0; // int flag; // for (i = 0; i < N; i++) { // flag=0; // for (j= 0; j < n_unique; j++) { // if (xy0[i]==unique[j]) { // //PRINTF("inside\n"); // nties[j]++; // flag=1; // break; // } // } // if(flag==0) unique[n_unique++]=xy0[i]; // } // //for (i = 0; i < n_unique; i++) PRINTF("%f ", unique[i]); PRINTF("\n"); // //for (i = 0; i < n_unique; i++) PRINTF("%i ", nties[i]); PRINTF("\n"); // // sum(NTIES^3-NTIES)/(12*m*n*N*(N - 1)) double adj=0; // for (i = 0; i < n_unique; i++) { // if(nties[i]>1) adj+= (pow(nties[i],3)-nties[i]); // } // adj/=(12.*m*n*N*(N-1)); if(mc_rep==1) { ans[0]=compute_pair_wmw_Z(X0, Y0, xy, m, n, corr, method, adj, 0); } else { if (mc_rep>1) { // Monte Carlo for (b=0; b<mc_rep; b++) { for (i = 0; i < m; i++) { ind=RUNIF(0.0,1.0); X[i]=ind< 0.5?X0[i]:Y0[i]; Y[i]=ind>=0.5?X0[i]:Y0[i]; } ans[b]=compute_pair_wmw_Z(X, Y, xy, m, n, corr, method, adj, 0); } } else { // exact int c=0; for (b=0; b<nperm; b++) { //PRINTF("%i ", b); for (i = 0; i < m; i++) { ind=comb[c++]; X[i]=ind==0?X0[i]:Y0[i]; Y[i]=ind==1?X0[i]:Y0[i]; } ans[b]=compute_pair_wmw_Z(X, Y, xy, m, n, corr, method, adj, 0); } } //for (b=0; b<mc_rep; b++) PRINTF("%f ", ans[b]); PRINTF("\n"); } free(X); free(Y); free(xy); free(unique); free(nties); UNPROTECT(1); return _ans; }
/*It imports the data from an arc file*/ SEXP get_arc_data(SEXP directory, SEXP coverage, SEXP filename) { int i,j,n, **ptable; double *x,*y; char pathtofile[PATH]; AVCArc *reg; AVCBinFile *file; SEXP *table, points, aux; strcpy(pathtofile, CHAR(STRING_ELT(directory,0))); complete_path(pathtofile, (char *)CHAR(STRING_ELT(coverage,0)), 1); if(!(file=AVCBinReadOpen(pathtofile,CHAR(STRING_ELT(filename,0)), AVCFileARC))) error("Error opening file"); n=0; while(AVCBinReadNextArc(file)){n++;} Rprintf("Number of ARCS:%d\n",n); table=calloc(7,sizeof(SEXP)); ptable=(int **)calloc(7, sizeof(int *)); for(i=0;i<7;i++) { PROTECT(table[i]=NEW_INTEGER(n)); ptable[i]=(int *)INTEGER(table[i]); } PROTECT(points=NEW_LIST(n)); if(AVCBinReadRewind(file)) error("Rewind"); for(i=0;i<n;i++) { if(!(reg=(AVCArc*)AVCBinReadNextArc(file))) error("Error while reading register"); ptable[0][i]=reg->nArcId; ptable[1][i]=reg->nUserId; ptable[2][i]=reg->nFNode; ptable[3][i]=reg->nTNode; ptable[4][i]=reg->nLPoly; ptable[5][i]=reg->nRPoly; ptable[6][i]=reg->numVertices; SET_VECTOR_ELT(points,i,NEW_LIST(2)); aux=VECTOR_ELT(points,i); SET_VECTOR_ELT(aux,0,NEW_NUMERIC(reg->numVertices)); SET_VECTOR_ELT(aux,1,NEW_NUMERIC(reg->numVertices)); x=REAL(VECTOR_ELT(aux,0)); y=REAL(VECTOR_ELT(aux,1)); for(j=0;j<reg->numVertices;j++) { x[j]=reg->pasVertices[j].x; y[j]=reg->pasVertices[j].y; } } PROTECT(aux=NEW_LIST(8)); for(i=0;i<7;i++) { SET_VECTOR_ELT(aux,i,table[i]); } SET_VECTOR_ELT(aux,7,points); UNPROTECT(9); free(table); return aux; }
/** * Logistic regression stochastic average gradient trainer * * @param w(p, 1) weights * @param Xt(p, n) real feature matrix * @param y(n, 1) {-1, 1} target matrix * @param lambda scalar regularization parameters * @param Li scalar constant step size * @param iVals(max_iter, 1) sequence of examples to choose * @param d(p, 1) initial approximation of average gradient * @param g(n, 1) previous derivatives of loss * @param covered(n, 1) whether the example has been visited * @param stepSizeType scalar default is 1 to use 1/L, set to 2 to * use 2/(L + n*myu) * @return optimal weights (p, 1) */ SEXP C_sag(SEXP wInit, SEXP Xt, SEXP y, SEXP lambdas, SEXP alpha, // SAG Constant Step size SEXP stepSizeType, // SAG Linesearch SEXP LiInit, // SAG Linesearch and Adaptive SEXP LmaxInit, // SAG Adaptive SEXP increasing, // SAG Adaptive SEXP dInit, SEXP gInit, SEXP coveredInit, SEXP tol, SEXP maxiter, SEXP family, SEXP fit_alg, SEXP ex_model_params, SEXP sparse) { /*===============\ | Error Checking | \===============*/ validate_inputs(wInit, Xt, y, dInit, gInit, coveredInit, sparse); /* Initializing protection counter */ int nprot = 0; /* Duplicating objects to be modified */ SEXP w = PROTECT(duplicate(wInit)); nprot++; SEXP d = PROTECT(duplicate(dInit)); nprot++; SEXP g = PROTECT(duplicate(gInit)); nprot++; SEXP covered = PROTECT(duplicate(coveredInit)); nprot++; SEXP Li = PROTECT(duplicate(LiInit)); nprot++; SEXP Lmax = PROTECT(duplicate(LmaxInit)); nprot++; /*======\ | Input | \======*/ /* Initializing dataset */ Dataset train_set = make_Dataset(Xt, y, covered, Lmax, Li, increasing, fit_alg, sparse); /* Initializing Trainer */ GlmTrainer trainer = make_GlmTrainer(R_NilValue, alpha, d, g, maxiter, stepSizeType, tol, fit_alg, R_NilValue, R_NilValue); /* Initializing Model */ GlmModel model = make_GlmModel(w, family, ex_model_params); /*============================\ | Stochastic Average Gradient | \============================*/ /* Initializing lambda/weights Matrix*/ SEXP lambda_w = PROTECT(allocMatrix(REALSXP, train_set.nVars, LENGTH(lambdas))); nprot++; Memzero(REAL(lambda_w), LENGTH(lambdas) * train_set.nVars); /* Training */ sag_warm(&trainer, &model, &train_set, REAL(lambdas), LENGTH(lambdas), REAL(lambda_w)); /* Cleanup */ cleanup(&trainer, &model, &train_set); /*=======\ | Return | \=======*/ SEXP convergence_code = PROTECT(allocVector(INTSXP, 1)); nprot++; *INTEGER(convergence_code) = trainer.convergence_code; SEXP iter_count = PROTECT(allocVector(INTSXP, 1)); nprot++; *INTEGER(iter_count) = trainer.iter_count; /* Assigning variables to SEXP list */ SEXP results = PROTECT(allocVector(VECSXP, 8)); nprot++; INC_APPLY(SEXP, SET_VECTOR_ELT, results, lambda_w, d, g, covered, Li, Lmax, convergence_code, iter_count); // in utils.h /* Creating SEXP for list names */ SEXP results_names = PROTECT(allocVector(STRSXP, 8)); nprot++; INC_APPLY_SUB(char *, SET_STRING_ELT, mkChar, results_names, "lambda_w", "d", "g", "covered", "Li", "Lmax", "convergence_code", "iter_count"); setAttrib(results, R_NamesSymbol, results_names); /* ------------------------------------------------------------------------ */ UNPROTECT(nprot); return results; }
SEXP get_pal_data(SEXP directory, SEXP coverage, SEXP filename) { int i,j,n; int **idata; char pathtofile[PATH]; void **ptable; AVCPal *reg; AVCBinFile *file; SEXP *table, points, aux; strcpy(pathtofile, CHAR(STRING_ELT(directory,0))); complete_path(pathtofile, (char *) CHAR(STRING_ELT(coverage,0)), 1); if(!(file=AVCBinReadOpen(pathtofile,CHAR(STRING_ELT(filename,0)), AVCFilePAL))) error("Error opening file"); n=0; while(AVCBinReadNextPal(file)){n++;} Rprintf("Number of POLYGONS:%d\n",n); idata=calloc(3,sizeof(int *)); table=calloc(6,sizeof(SEXP)); ptable=(void **)calloc(6, sizeof(void *)); PROTECT(table[0]=NEW_INTEGER(n)); /*Polygon ID*/ ptable[0]=(int *)INTEGER(table[0]); PROTECT(table[1]=NEW_NUMERIC(n)); /*Min X. coordinate*/ ptable[1]=(double *)REAL(table[1]); PROTECT(table[2]=NEW_NUMERIC(n)); /*Min Y. coordinate*/ ptable[2]=(double *)REAL(table[2]); PROTECT(table[3]=NEW_NUMERIC(n)); /*Max X. coordinate*/ ptable[3]=(double *)REAL(table[3]); PROTECT(table[4]=NEW_NUMERIC(n)); /*Max Y. coordinate*/ ptable[4]=(double *)REAL(table[4]); PROTECT(table[5]=NEW_INTEGER(n)); /*Number of arcs*/ ptable[5]=(int *)INTEGER(table[5]); PROTECT(points=NEW_LIST(n)); if(AVCBinReadRewind(file)) error("Rewind"); for(i=0;i<n;i++) { if(!(reg=(AVCPal*)AVCBinReadNextPal(file))) error("Error while reading register"); ((int *)ptable[0])[i]=reg->nPolyId; ((double *)ptable[1])[i]=reg->sMin.x; ((double *)ptable[2])[i]=reg->sMin.y; ((double *)ptable[3])[i]=reg->sMax.x; ((double *)ptable[4])[i]=reg->sMax.y; ((int *)ptable[5])[i]=reg->numArcs; SET_VECTOR_ELT(points,i,NEW_LIST(3)); aux=VECTOR_ELT(points,i); SET_VECTOR_ELT(aux,0,NEW_INTEGER(reg->numArcs)); idata[0]=INTEGER(VECTOR_ELT(aux,0)); SET_VECTOR_ELT(aux,1,NEW_INTEGER(reg->numArcs)); idata[1]=INTEGER(VECTOR_ELT(aux,1)); SET_VECTOR_ELT(aux,2,NEW_INTEGER(reg->numArcs)); idata[2]=INTEGER(VECTOR_ELT(aux,2)); for(j=0;j<reg->numArcs;j++) { idata[0][j]=reg->pasArcs[j].nArcId; idata[1][j]=reg->pasArcs[j].nFNode; idata[2][j]=reg->pasArcs[j].nAdjPoly; } } PROTECT(aux=NEW_LIST(7)); for(i=0;i<6;i++) { SET_VECTOR_ELT(aux,i,table[i]); } SET_VECTOR_ELT(aux,6,points); UNPROTECT(8); free(ptable); free(idata); return aux; }
SEXP calc_het(SEXP C, SEXP LG, SEXP n, SEXP ncol, SEXP nrow) /*********************************************************************** * Functie om de heterogeniteit van een 3x3 focal area (neighbourhood) * in de LG kaart te berekenen. * * INVOER: * * C = celnummers van geselecteerde rastercellen * LG = LG kaart (geselecteerde cellen) als vector (de LG kaart mag * alleen de codes 1 t/m 5 of een NA bevatten!) * n = lengte van 'C' * ncol = aantal kolommen in LG-kaart * nrow = aantal rijen in LG-kaart * * UITVOER: * * Een vector met lengte n en van type INTEGER. * ***********************************************************************/ { double *tmp; // tijdelijke vector voor volle LG kaart double code; // code op basis van LG waarden in focal area int i, k; // iteratoren int index; double *xlg = REAL(LG); int *xc = INTEGER(C); int *xn = INTEGER(n), *xncol = INTEGER(ncol), *xnrow = INTEGER(nrow); int m = *xncol * *xnrow; int focal[9] = {-(*xncol+1), -*xncol, -(*xncol-1), -1, 0, 1, *xncol-1, *xncol, *xncol+1}; tmp = Calloc(m,double); for (i = 0; i < *xn; i++) { if (!ISNA(xlg[i])) { tmp[xc[i]] = xlg[i]; } } SEXP HET; PROTECT(HET=allocVector(INTSXP,*xn)); int *het = INTEGER(HET); for (i = 0; i < *xn; i++) { if (!ISNA(xlg[i])) { code = 0; for (k = 0; k < 9; k++) { index = xc[i] + focal[k]; if (!(index < 1 || index > m)) { code += pow(10.0, tmp[index-1]); } } het[i] = code2het(code); } else { het[i] = NA_INTEGER; } } Free(tmp); UNPROTECT(1); return(HET); }
SEXP get_cnt_data(SEXP directory, SEXP coverage, SEXP filename) { int i,j,n, *ilabel; void **pdata; char pathtofile[PATH]; AVCCnt *reg; AVCBinFile *file; SEXP *table, label, aux; strcpy(pathtofile, CHAR(STRING_ELT(directory,0))); complete_path(pathtofile, (char *) CHAR(STRING_ELT(coverage,0)),1);/*FIXME*/ if(!(file=AVCBinReadOpen(pathtofile,CHAR(STRING_ELT(filename,0)), AVCFileCNT))) error("Error opening file"); n=0; while(AVCBinReadNextCnt(file)){n++;} Rprintf("Number of CENTROIDS:%d\n",n); table=calloc(4, sizeof(SEXP)); pdata=calloc(4,sizeof(void *)); PROTECT(table[0]=NEW_INTEGER(n)); pdata[0]=INTEGER(table[0]); PROTECT(table[1]=NEW_NUMERIC(n)); pdata[1]=REAL(table[1]); PROTECT(table[2]=NEW_NUMERIC(n)); pdata[2]=REAL(table[2]); PROTECT(table[3]=NEW_INTEGER(n)); pdata[3]=INTEGER(table[3]); PROTECT(label=NEW_LIST(n)); if(AVCBinReadRewind(file)) error("Rewind"); for(i=0;i<n;i++) { if(!(reg=(AVCCnt*)AVCBinReadNextCnt(file))) error("Error while reading register"); ((int *)pdata[0])[i]=reg->nPolyId; ((double *)pdata[1])[i]=reg->sCoord.x; ((double *)pdata[2])[i]=reg->sCoord.y; ((int *)pdata[3])[i]=reg->numLabels; SET_VECTOR_ELT(label,i,NEW_INTEGER(reg->numLabels)); ilabel=INTEGER(VECTOR_ELT(label,i)); if(reg->numLabels >0) { for(j=0;j<reg->numLabels;j++) { /* printf("%d\n", reg->panLabelIds[j]);*/ ilabel[j]=reg->panLabelIds[j]; } } } PROTECT(aux=NEW_LIST(5)); for(i=0;i<4;i++) SET_VECTOR_ELT(aux, i, table[i]); SET_VECTOR_ELT(aux, 4, label); UNPROTECT(6); free(table); free(pdata); return aux; }
SEXP _match_matrix(SEXP x, SEXP y, SEXP _nm) { if (TYPEOF(x) != INTSXP) error("'x' not integer"); int nr, nc; SEXP r; if (!isMatrix(x)) error("'x' not a matrix"); r = getAttrib(x, R_DimSymbol); nr = INTEGER(r)[0]; nc = INTEGER(r)[1]; int ny = 0, nm = NA_INTEGER; if (!isNull(y)) { if (TYPEOF(y) != INTSXP) error("'y' not integer"); if (!isMatrix(y)) error("'y' not a matrix"); r = getAttrib(y, R_DimSymbol); ny = INTEGER(r)[0]; if (nc != INTEGER(r)[1]) error("'x, y' number of columns don't match"); if (!isNull(_nm)) { if (TYPEOF(_nm) != INTSXP) error("'nm' not integer"); if (LENGTH(_nm)) nm = INTEGER(_nm)[0]; } } // Initialize hash table. int hk, k, n; SEXP ht; if (nr > 1073741824) error("size %d too large for hashing", nr); k = 2 * nr; n = 2; hk = 1; while (k > n) { n *= 2; hk += 1; } ht = PROTECT(allocVector(INTSXP, n)); for (k = 0; k < n; k++) INTEGER(ht)[k] = -1; // Match. SEXP s; r = PROTECT(allocVector(VECSXP, 2)); SET_VECTOR_ELT(r, 0, (s = allocVector(INTSXP, nr))); n = 0; for (k = 0; k < nr; k++) { int j = _ihadd(INTEGER(x), nr, nc, k, INTEGER(x), nr, ht, hk); if (j > -1) INTEGER(s)[k] = INTEGER(s)[j]; else { n++; INTEGER(s)[k] = n; } } if (!isNull(y)) { SEXP t; SET_VECTOR_ELT(r, 1, (t = allocVector(INTSXP, ny))); for (k = 0; k < ny; k++) { int j = _ihadd(INTEGER(y), ny, nc, k, INTEGER(x), nr, ht, hk); if (j > -1) INTEGER(t)[k] = INTEGER(s)[j]; else INTEGER(t)[k] = nm; } UNPROTECT(2); return r; } // Unique. SEXP t; SET_VECTOR_ELT(r, 1, (t = allocVector(INTSXP, n))); n = 1; for (k = 0; k < nr; k++) if (INTEGER(s)[k] == n) { INTEGER(t)[n - 1] = k + 1; n++; } UNPROTECT(2); return r; }
SEXP get_table_data(SEXP infodir, SEXP tablename) { int i,j,n; char pathtoinfodir[PATH]; void **pdata; AVCTableDef *tabledef; AVCField *reg; AVCBinFile *file; SEXP *table,aux; strcpy(pathtoinfodir, CHAR(STRING_ELT(infodir,0))); complete_path(pathtoinfodir, "", 1); if(!(file=AVCBinReadOpen(pathtoinfodir,CHAR(STRING_ELT(tablename,0)),AVCFileTABLE))) { error("Couldn't open table file\n"); } n=0; while(AVCBinReadNextTableRec(file)){n++;} AVCBinReadRewind(file); tabledef=(file->hdr).psTableDef; table=calloc(tabledef->numFields, sizeof(SEXP)); pdata=calloc(tabledef->numFields, sizeof(void *)); for(i=0;i<tabledef->numFields;i++) { /*printf("%d %d %d\n",i,j,tabledef->pasFieldDef[j].nType1);*/ switch(tabledef->pasFieldDef[i].nType1) { case 1: case 2: PROTECT(table[i]=NEW_STRING(n));break; case 3: PROTECT(table[i]=NEW_INTEGER(n)); pdata[i]=(int *)INTEGER(table[i]);break; case 4: PROTECT(table[i]=NEW_NUMERIC(n)); pdata[i]=(double *)REAL(table[i]);break; case 5: PROTECT(table[i]=NEW_INTEGER(n)); pdata[i]=(int *)INTEGER(table[i]);break; case 6: PROTECT(table[i]=NEW_NUMERIC(n)); pdata[i]=(double *)REAL(table[i]);break; } } for(i=0;i<n;i++) { reg=AVCBinReadNextTableRec(file); for(j=0;j<tabledef->numFields;j++) { /* printf("%d %d %d\n",i,j,tabledef->pasFieldDef[j].nType1);*/ switch(tabledef->pasFieldDef[j].nType1) { case 1: case 2: SET_STRING_ELT(table[j],i, COPY_TO_USER_STRING(reg[j].pszStr)); break; case 3: ((int *)pdata[j])[i]=atoi(reg[j].pszStr); break; case 4: ((double *)pdata[j])[i]=atof(reg[j].pszStr); break; case 5: if(reg[j].nInt16!=0)/*Single precision*/ ((int *)pdata[j])[i]=reg[j].nInt16; else/*Default and double precision*/ ((int *)pdata[j])[i]=reg[j].nInt32; break; case 6: if(reg[j].fFloat!=0)/*Single precision*/ ((double *)pdata[j])[i]=reg[j].fFloat; else/*Default and double precision*/ ((double *)pdata[j])[i]=reg[j].dDouble; break; } } } PROTECT(aux=NEW_LIST(tabledef->numFields)); for(i=0;i<tabledef->numFields;i++) SET_VECTOR_ELT(aux, i, table[i]); UNPROTECT(1+tabledef->numFields); free(table); free(pdata); return aux; }
SEXP _ini_array(SEXP d, SEXP p, SEXP v, SEXP s) { if (TYPEOF(d) != INTSXP || TYPEOF(p) != INTSXP || TYPEOF(s) != INTSXP) error("'d, p, s' not integer"); int n, m; SEXP r, dd; if (!isVector(v)) error("'v' not a vector"); if (isMatrix(p)) { r = getAttrib(p, R_DimSymbol); n = INTEGER(r)[0]; if (n != LENGTH(v)) error("'p' and 'v' do not conform"); m = INTEGER(r)[1]; if (m != LENGTH(d)) error("'p' and 'd' do not conform"); r = PROTECT(allocArray(TYPEOF(v), d)); } else { n = LENGTH(p); if (n != LENGTH(v)) error("'p' and 'v' do not conform"); m = 1; if (m != LENGTH(d)) error("'p' and 'd' do not conform"); r = PROTECT(allocVector(TYPEOF(v), INTEGER(d)[0])); } switch(TYPEOF(v)) { case LGLSXP: case INTSXP: memset(INTEGER(r), 0, sizeof(int) * LENGTH(r)); break; case REALSXP: memset(REAL(r), 0, sizeof(double) * LENGTH(r)); break; case RAWSXP: memset(RAW(r), 0, sizeof(char) * LENGTH(r)); break; case CPLXSXP: memset(COMPLEX(r), 0, sizeof(Rcomplex) * LENGTH(r)); break; case EXPRSXP: case VECSXP: for (int i = 0; i < LENGTH(r); i++) SET_VECTOR_ELT(r, i, R_NilValue); break; case STRSXP: for (int i = 0; i < LENGTH(r); i++) SET_STRING_ELT(r, i, R_BlankString); break; default: error("type of 'v' not supported"); } if (m > 2) { dd = PROTECT(duplicate(d)); for (int i = 1; i < m - 1; i++) INTEGER(dd)[i] *= INTEGER(dd)[i-1]; } else dd = d; for (int i = 0; i < LENGTH(s); i++) { int k = INTEGER(s)[i]; if (k < 1 || k > n) error("'s' invalid"); k--; int h = k; int l = INTEGER(p)[k]; if (l < 1 || l > INTEGER(d)[0]) error("'p' invalid"); l--; for (int j = 1; j < m; j++) { k += n; int ll = INTEGER(p)[k]; if (ll < 1 || ll > INTEGER(d)[j]) error("'p' invalid"); ll--; l += INTEGER(dd)[j - 1] * ll; } switch(TYPEOF(v)) { case LGLSXP: case INTSXP: INTEGER(r)[l] = INTEGER(v)[h]; break; case REALSXP: REAL(r)[l] = REAL(v)[h]; break; case RAWSXP: RAW(r)[l] = RAW(v)[h]; break; case CPLXSXP: COMPLEX(r)[l] = COMPLEX(v)[h]; break; case EXPRSXP: case VECSXP: SET_VECTOR_ELT(r, l, VECTOR_ELT(v, h)); break; case STRSXP: SET_STRING_ELT(r, l, STRING_ELT(v, h)); break; default: error("type of 'v' not supported"); } } UNPROTECT(1 + (m > 2)); return r; }
/* par fn gr options */ SEXP optimhess(SEXP call, SEXP op, SEXP args, SEXP rho) { SEXP par, fn, gr, options, tmp, ndeps, ans; OptStruct OS; int npar, i , j; double *dpar, *df1, *df2, eps; args = CDR(args); OS = (OptStruct) R_alloc(1, sizeof(opt_struct)); OS->usebounds = 0; OS->R_env = rho; par = CAR(args); npar = LENGTH(par); OS->names = getAttrib(par, R_NamesSymbol); args = CDR(args); fn = CAR(args); if (!isFunction(fn)) error(_("'fn' is not a function")); args = CDR(args); gr = CAR(args); args = CDR(args); options = CAR(args); OS->fnscale = asReal(getListElement(options, "fnscale")); tmp = getListElement(options, "parscale"); if (LENGTH(tmp) != npar) error(_("'parscale' is of the wrong length")); PROTECT(tmp = coerceVector(tmp, REALSXP)); OS->parscale = vect(npar); for (i = 0; i < npar; i++) OS->parscale[i] = REAL(tmp)[i]; UNPROTECT(1); PROTECT(OS->R_fcall = lang2(fn, R_NilValue)); PROTECT(par = coerceVector(par, REALSXP)); if (!isNull(gr)) { if (!isFunction(gr)) error(_("'gr' is not a function")); PROTECT(OS->R_gcall = lang2(gr, R_NilValue)); } else { PROTECT(OS->R_gcall = R_NilValue); /* for balance */ } ndeps = getListElement(options, "ndeps"); if (LENGTH(ndeps) != npar) error(_("'ndeps' is of the wrong length")); OS->ndeps = vect(npar); PROTECT(ndeps = coerceVector(ndeps, REALSXP)); for (i = 0; i < npar; i++) OS->ndeps[i] = REAL(ndeps)[i]; UNPROTECT(1); PROTECT(ans = allocMatrix(REALSXP, npar, npar)); dpar = vect(npar); for (i = 0; i < npar; i++) dpar[i] = REAL(par)[i] / (OS->parscale[i]); df1 = vect(npar); df2 = vect(npar); for (i = 0; i < npar; i++) { eps = OS->ndeps[i]/(OS->parscale[i]); dpar[i] = dpar[i] + eps; fmingr(npar, dpar, df1, (void *)OS); dpar[i] = dpar[i] - 2 * eps; fmingr(npar, dpar, df2, (void *)OS); for (j = 0; j < npar; j++) REAL(ans)[i * npar + j] = (OS->fnscale) * (df1[j] - df2[j])/ (2 * eps * (OS->parscale[i]) * (OS->parscale[j])); dpar[i] = dpar[i] + eps; } // now symmetrize for (i = 0; i < npar; i++) for (j = 0; j < i; j++) { double tmp = 0.5 * (REAL(ans)[i * npar + j] + REAL(ans)[j * npar + i]); REAL(ans)[i * npar + j] = REAL(ans)[j * npar + i] = tmp; } SEXP nm = getAttrib(par, R_NamesSymbol); if(!isNull(nm)) { SEXP dm; PROTECT(dm = allocVector(VECSXP, 2)); SET_VECTOR_ELT(dm, 0, duplicate(nm)); SET_VECTOR_ELT(dm, 1, duplicate(nm)); setAttrib(ans, R_DimNamesSymbol, dm); UNPROTECT(1); } UNPROTECT(4); return ans; }
/* Given a minc filename, return a list containing: (1) the dimension names (2) the dimension sizes (3) and much, much more */ SEXP get_volume_info(SEXP filename) { mihandle_t minc_volume; midimhandle_t *dimensions; miclass_t volume_class; mitype_t volume_type; int result, i; int n_dimensions; int n_protects, list_index; int n_frames; // variables to hold dim-related info misize_t dim_sizes[MI2_MAX_VAR_DIMS]; double dim_starts[MI2_MAX_VAR_DIMS]; double dim_steps[MI2_MAX_VAR_DIMS]; double time_offsets[MAX_FRAMES]; double time_widths[MAX_FRAMES]; char *dim_name; char *dim_units; char *space_type; Rboolean time_dim_exists; static char *dimorder3d[] = { "zspace","yspace","xspace" }; static char *dimorder4d[] = { "time", "zspace","yspace","xspace" }; /* declare R datatypes */ SEXP rtnList, listNames; SEXP xDimSizes, xDimNames, xDimUnits, xDimStarts, xDimSteps, xTimeWidths, xTimeOffsets; // start ... if ( R_DEBUG_rmincIO ) Rprintf("get_volume_info: start ...\n"); /* do some initialization */ for (i=0; i < MI2_MAX_VAR_DIMS; ++i){ // set dim info to zeros dim_sizes[i] = 0; dim_starts[i] = 0; dim_steps[i] = 0; } // frame-related init time_dim_exists = FALSE; for (i=0; i < MAX_FRAMES; ++i) { time_offsets[i]=999.9; time_widths[i]=999.9; } n_frames = 0; n_protects = 0; // counter of protected R variables /* init the return list (include list names) */ PROTECT(rtnList=allocVector(VECSXP, R_RTN_LIST_LEN)); PROTECT(listNames=allocVector(STRSXP, R_RTN_LIST_LEN)); n_protects = n_protects +2; /* open the existing volume */ result = miopen_volume(CHAR(STRING_ELT(filename,0)), MI2_OPEN_READ, &minc_volume); /* error on open? */ if (result != MI_NOERROR) { error("Error opening input file: %s.\n", CHAR(STRING_ELT(filename,0))); } /* set the apparent order to something conventional */ // ... first need to get the number of dimensions if ( miget_volume_dimension_count(minc_volume, MI_DIMCLASS_ANY, MI_DIMATTR_ALL, &n_dimensions) != MI_NOERROR ){ error("Error returned from miget_volume_dimension_count.\n"); } // ... now set the order if ( R_DEBUG_rmincIO ) Rprintf("Setting the apparent order for %d dimensions ... ", n_dimensions); if ( n_dimensions == 3 ) { result = miset_apparent_dimension_order_by_name(minc_volume, 3, dimorder3d); } else if ( n_dimensions == 4 ) { result = miset_apparent_dimension_order_by_name(minc_volume, 4, dimorder4d); } else { error("Error file %s has %d dimensions and we can only deal with 3 or 4.\n", CHAR(STRING_ELT(filename,0)), n_dimensions); } if ( result != MI_NOERROR ) { error("Error returned from miset_apparent_dimension_order_by_name while setting apparent order for %d dimensions.\n", n_dimensions); } if ( R_DEBUG_rmincIO ) Rprintf("Done.\n"); /* get the volume data class (the intended "real" values) */ if ( miget_data_class(minc_volume, &volume_class) != MI_NOERROR ){ error("Error returned from miget_data_class.\n"); } /* append to return list ... */ list_index = 0; SET_VECTOR_ELT(rtnList, list_index, ScalarInteger(volume_class)); SET_STRING_ELT(listNames, list_index, mkChar("volumeDataClass")); /* print the volume data type (as it is actually stored in the volume) */ if ( miget_data_type(minc_volume, &volume_type) != MI_NOERROR ){ error("Error returned from miget_data_type.\n"); } /* append to return list ... */ list_index++; SET_VECTOR_ELT(rtnList, list_index, ScalarInteger(volume_type)); SET_STRING_ELT(listNames, list_index, mkChar("volumeDataType")); /* retrieve the volume space type (talairach, native, etc) */ result = miget_space_name(minc_volume, &space_type); if ( result == MI_NOERROR ) { error("Error returned from miget_space_name.\n"); } /* append to return list ... */ list_index++; SET_VECTOR_ELT(rtnList, list_index, mkString(space_type)); SET_STRING_ELT(listNames, list_index, mkChar("spaceType")); /* retrieve the total number of dimensions in this volume */ if ( miget_volume_dimension_count(minc_volume, MI_DIMCLASS_ANY, MI_DIMATTR_ALL, &n_dimensions) != MI_NOERROR ){ error("Error returned from miget_volume_dimension_count.\n"); } /* append to return list ... */ list_index++; SET_VECTOR_ELT(rtnList, list_index, ScalarInteger(n_dimensions)); SET_STRING_ELT(listNames, list_index, mkChar("nDimensions")); /* load up dimension-related information */ // /* first allocate the R variables */ PROTECT( xDimSizes=allocVector(INTSXP,n_dimensions) ); PROTECT( xDimNames=allocVector(STRSXP,n_dimensions) ); PROTECT( xDimUnits=allocVector(STRSXP,n_dimensions) ); PROTECT( xDimStarts=allocVector(REALSXP,n_dimensions) ); PROTECT( xDimSteps=allocVector(REALSXP,n_dimensions) ); n_protects = n_protects +5; /* next, load up the midimension struct for all dimensions*/ dimensions = (midimhandle_t *) malloc( sizeof( midimhandle_t ) * n_dimensions ); result = miget_volume_dimensions(minc_volume, MI_DIMCLASS_ANY, MI_DIMATTR_ALL, MI_DIMORDER_APPARENT, n_dimensions, dimensions); // need to check against MI_ERROR, as "result" will contain nDimensions if OK if ( result == MI_ERROR ) { error("Error code(%d) returned from miget_volume_dimensions.\n", result); } /* get the dimension sizes for all dimensions */ result = miget_dimension_sizes(dimensions, n_dimensions, dim_sizes); if ( result != MI_NOERROR ) { error("Error returned from miget_dimension_sizes.\n"); } /* add to R vector ... */ for (i=0; i<n_dimensions; ++i){ INTEGER(xDimSizes)[i] = dim_sizes[i]; } list_index++; SET_VECTOR_ELT(rtnList, list_index, xDimSizes); SET_STRING_ELT(listNames, list_index, mkChar("dimSizes")); /* get the dimension START values for all dimensions */ result = miget_dimension_starts(dimensions, MI_ORDER_FILE, n_dimensions, dim_starts); if ( result == MI_ERROR ) { error("Error returned from miget_dimension_starts.\n"); } /* add to R vector ... */ for (i=0; i<n_dimensions; ++i){ REAL(xDimStarts)[i] = dim_starts[i]; } list_index++; SET_VECTOR_ELT(rtnList, list_index, xDimStarts); SET_STRING_ELT(listNames, list_index, mkChar("dimStarts")); /* get the dimension STEP values for all dimensions */ result = miget_dimension_separations(dimensions, MI_ORDER_FILE, n_dimensions, dim_steps); if ( result == MI_ERROR ) { error("Error returned from miget_dimension_separations.\n"); } /* add to R vector ... */ for (i=0; i<n_dimensions; ++i){ REAL(xDimSteps)[i] = dim_steps[i]; } list_index++; SET_VECTOR_ELT(rtnList, list_index, xDimSteps); SET_STRING_ELT(listNames, list_index, mkChar("dimSteps")); /* Loop over the dimensions to grab the remaining info ... */ for( i=0; i < n_dimensions; ++i ){ // /* get (and print) the dimension names for all dimensions* ... remember that since miget_dimension_name calls strdup which, in turn, ... calls malloc to get memory for the new string -- we need to call "mifree" on ... our pointer to release that memory. */ result = miget_dimension_name(dimensions[i], &dim_name); // do we have a time dimension? if ( !strcmp(dim_name, "time") ) { time_dim_exists = TRUE; n_frames = ( time_dim_exists ) ? dim_sizes[0] : 0; } // store the dimension name and units SET_STRING_ELT(xDimNames, i, mkChar(dim_name)); mifree_name(dim_name); result = miget_dimension_units(dimensions[i], &dim_units); SET_STRING_ELT(xDimUnits, i, mkChar(dim_units)); mifree_name(dim_units); } /* add number of frames to return list */ list_index++; SET_VECTOR_ELT(rtnList, list_index, ScalarInteger(n_frames)); SET_STRING_ELT(listNames, list_index, mkChar("nFrames")); // add dim names to return list list_index++; SET_VECTOR_ELT(rtnList, list_index, xDimNames); SET_STRING_ELT(listNames, list_index, mkChar("dimNames")); // add dim units list_index++; SET_VECTOR_ELT(rtnList, list_index, xDimUnits); SET_STRING_ELT(listNames, list_index, mkChar("dimUnits")); /* get the dimension OFFSETS values for the TIME dimension */ if ( time_dim_exists ) { PROTECT( xTimeOffsets=allocVector(REALSXP,n_frames) ); n_protects++; result = miget_dimension_offsets(dimensions[0], n_frames, 0, time_offsets); if ( result == MI_ERROR ) { error("Error returned from miget_dimension_offsets.\n"); } /* add to R vector ... */ for (i=0; i < n_frames; ++i) { REAL(xTimeOffsets)[i] = time_offsets[i]; // if (R_DEBUG_rmincIO) Rprintf("Time offset[%d] = %g\n", i, time_offsets[i]); } list_index++; SET_VECTOR_ELT(rtnList, list_index, xTimeOffsets); SET_STRING_ELT(listNames, list_index, mkChar("timeOffsets")); /* get the dimension WIDTH values for the TIME dimension */ PROTECT( xTimeWidths=allocVector(REALSXP,n_frames) ); n_protects++; result = miget_dimension_widths(dimensions[0], MI_ORDER_FILE, n_frames, 0, time_widths); if ( result == MI_ERROR ) { error("Error returned from miget_dimension_widths.\n"); } /* add to R vector ... */ for (i=0; i<n_frames; ++i) { REAL(xTimeWidths)[i] = time_widths[i]; // if (R_DEBUG_rmincIO) Rprintf("Time width[%d] = %g\n", i, time_widths[i]); } list_index++; SET_VECTOR_ELT(rtnList, list_index, xTimeWidths); SET_STRING_ELT(listNames, list_index, mkChar("timeWidths")); } // free heap memory free(dimensions); /* close volume */ miclose_volume(minc_volume); /* attach the list component names to the list */ setAttrib(rtnList, R_NamesSymbol, listNames); /* remove gc collection protection */ UNPROTECT(n_protects); /* return */ if ( R_DEBUG_rmincIO ) Rprintf("get_volume_info: returning ...\n"); return(rtnList); }
SEXP additiveFunctionValues(SEXP reachIDs, SEXP binaryIDs, SEXP proportionalInfluences, SEXP netIDs) { unsigned int nReachIDs = LENGTH(reachIDs); unsigned int nBinaryIDs = LENGTH(binaryIDs); unsigned int nProportionalInfluences = LENGTH(proportionalInfluences); unsigned int nNetIDs = LENGTH(netIDs); typedef std::map<int, NetworkPtr> NetworksMapType; std::vector<char*> allocatedStrings; NetworksMapType networks; if(nReachIDs != nBinaryIDs) { error("The number of input reach ID values must equal the number of input binary ID values\n"); return R_NilValue; } if(nBinaryIDs != nProportionalInfluences) { error("The number of input proportional influence values must equal the number of input binary ID values\n"); return R_NilValue; } if(nProportionalInfluences != nNetIDs) { error("The number of input proportional influence values must equal the number of input network ID values\n"); return R_NilValue; } if(TYPEOF(reachIDs) != INTSXP) { error("Input reach ID values must be integers\n"); return R_NilValue; } if(TYPEOF(binaryIDs) != STRSXP) { error("Input binary ID values must be character strings\n"); return R_NilValue; } if(TYPEOF(proportionalInfluences) != REALSXP) { error("Input proportional influence values must be floating point numeric\n"); return R_NilValue; } if(TYPEOF(netIDs) != INTSXP) { error("Input network ID values must be integers\n"); return R_NilValue; } int* networkIDs_pointer = INTEGER(netIDs); int* rids_pointer = INTEGER(reachIDs); double* proportionalInfluences_pointer = REAL(proportionalInfluences); //the returned value SEXP result = R_NilValue; std::vector<int> sortedNetworkIDs(networkIDs_pointer, networkIDs_pointer + nNetIDs); std::sort(sortedNetworkIDs.begin(), sortedNetworkIDs.end()); std::vector<int>::iterator unique_end = std::unique(sortedNetworkIDs.begin(), sortedNetworkIDs.end()); //initialize an entry for every network. for(std::vector<int>::iterator i = sortedNetworkIDs.begin(); i != unique_end; i++) { networks.insert(NetworksMapType::value_type(*i, NetworkPtr(new Network()))); } bool hasError = false; std::string errString; //construct tree data structure for(unsigned int i = 0; i < nNetIDs; i++) { int networkID = networkIDs_pointer[i]; const char* binaryRepresentation = CHAR(STRING_ELT(binaryIDs, i)); int representationLength = strlen(binaryRepresentation); //if there are spaces at the beginning or end we need to trim the string. This means we need to malloc our own copy, so track this in allocatedStrings if(isspace(binaryRepresentation[0]) || isspace(binaryRepresentation[representationLength-1])) { const char* start = binaryRepresentation; while(isspace(*start) && *start != 0) start++; if(*start == 0) { hasError = true; errString = "Blank binary ID detected"; goto cleanup; } else { const char* end = binaryRepresentation + representationLength - 1; while(isspace(*end)) end--; representationLength = end - start + 1; char* representation = new char[representationLength+1]; memcpy(representation, start, representationLength); //add null terminator representation[representationLength] = 0; allocatedStrings.push_back(representation); binaryRepresentation = representation; } } NetworkPtr currentNetwork = networks[networkID]; NodePtr newNode = NodePtr(new Node()); newNode->rid = rids_pointer[i]; newNode->index = i; newNode->binaryID = binaryRepresentation; newNode->proportionalInfluence = proportionalInfluences_pointer[i]; currentNetwork->allNodes.push_back(newNode); if(currentNetwork->binaryRepresentationsToNodes.find(binaryRepresentation) != currentNetwork->binaryRepresentationsToNodes.end()) { hasError = true; errString = "Duplicate binary IDs found"; goto cleanup; } currentNetwork->binaryRepresentationsToNodes.insert(Network::BinaryLookupMap::value_type(binaryRepresentation, newNode)); //if it's the root don't bother looking for parents if(std::strcmp(binaryRepresentation, "1") != 0) { char* parentBinaryID = strdup(binaryRepresentation); parentBinaryID[representationLength-1] = 0; Network::BinaryLookupMap::iterator findParent = currentNetwork->binaryRepresentationsToNodes.find(parentBinaryID); if(findParent != currentNetwork->binaryRepresentationsToNodes.end()) { //child one or child two? if(binaryRepresentation[representationLength-1] == '0') { findParent->second->child1 = newNode; } else { findParent->second->child2 = newNode; } newNode->parent = findParent->second; } free(parentBinaryID); } //if it's the root node, store it else { currentNetwork->rootNode = newNode; } char* childID = new char[representationLength+2]; strcpy(childID, binaryRepresentation); childID[representationLength] = '0'; childID[representationLength+1] = 0; Network::BinaryLookupMap::iterator possibleChild1 = currentNetwork->binaryRepresentationsToNodes.find(childID); if(possibleChild1 != currentNetwork->binaryRepresentationsToNodes.end()) { newNode->child1 = possibleChild1->second; possibleChild1->second->parent= newNode; } childID[representationLength] = '1'; Network::BinaryLookupMap::iterator possibleChild2 = currentNetwork->binaryRepresentationsToNodes.find(childID); if(possibleChild2 != currentNetwork->binaryRepresentationsToNodes.end()) { newNode->child2 = possibleChild2->second; possibleChild2->second->parent = newNode; } delete[] childID; } //normalize proportional influence values so that if we have two child nodes then their proportional influence values sum to 1 for(NetworksMapType::iterator i = networks.begin(); i != networks.end(); i++) { NetworkPtr currentNetwork = i-> second; for(std::vector<NodePtr>::iterator j = currentNetwork->allNodes.begin(); j != currentNetwork->allNodes.end(); j++) { //if it's not a terminal node, normalize. if((*j)->child1 && (*j)->child2) { double sum = (*j)->child1->proportionalInfluence + (*j)->child2->proportionalInfluence; (*j)->child1->proportionalInfluence /= sum; (*j)->child2->proportionalInfluence /= sum; } else if((*j)->child1) { (*j)->child1->proportionalInfluence = 1; } else if((*j)->child2) { (*j)->child2->proportionalInfluence = 1; } if(!(*j)->parent) { (*j)->proportionalInfluence = 1; } } } //storage for results PROTECT(result = allocVector(REALSXP, nNetIDs)); { double* result_pointer = REAL(result); //this next chunk is basically a by-hand tree-traversal algorithm. Ugly, but we need to limit any dependencies for(NetworksMapType::iterator i = networks.begin(); i != networks.end(); i++) { NetworkPtr currentNetwork = i->second; NodePtr currentNode = currentNetwork->rootNode; if(!currentNode) { std::stringstream ss; ss << "Root node not found for network "<< i->first; errString = ss.str(); hasError = true; goto cleanup; } currentNode->functionalValue = currentNode->proportionalInfluence; result_pointer[currentNode->index] = currentNode->proportionalInfluence; if(fabs(result_pointer[currentNode->index]) > 1) { errString = "Internal error, additive function value was out of range"; hasError = true; goto cleanup; } do { while(currentNode->child1 || (!currentNode->child1 && currentNode->child2)) { if(currentNode->child1) { currentNode = currentNode->child1; } else { currentNode = currentNode->child2; } currentNode->functionalValue = currentNode->proportionalInfluence * currentNode->parent->functionalValue; result_pointer[currentNode->index] = currentNode->functionalValue; if(fabs(result_pointer[currentNode->index]) > 1) { errString = "Internal error, additive function value was out of range"; hasError = true; goto cleanup; } } do { if(!currentNode->parent) { //we've finished for this network, so break out to the end of the for loop goto finish; } if(currentNode->parent->child1 && currentNode->parent->child1 == currentNode) { if(currentNode->parent->child2) { currentNode = currentNode->parent->child2; currentNode->functionalValue = currentNode->proportionalInfluence * currentNode->parent->functionalValue; result_pointer[currentNode->index] = currentNode->functionalValue; if(fabs(result_pointer[currentNode->index]) > 1) { errString = "Internal error, additive function value was out of range"; hasError = true; goto cleanup; } //we've finished this loop but we want to keep going on this network. So just break break; } else currentNode = currentNode->parent; } else currentNode = currentNode->parent; } while(true); } while(true); finish: ; } } UNPROTECT(1); cleanup: //cleanup code goes in a seperate loop, in case we break out of the previous one. for(NetworksMapType::iterator i = networks.begin(); i != networks.end(); i++) { NetworkPtr currentNetwork = i->second; //clean everything up for(std::vector<NodePtr>::iterator j = currentNetwork->allNodes.begin(); j != currentNetwork->allNodes.end(); j++) { (*j)->parent.reset(); (*j)->child1.reset(); (*j)->child2.reset(); } currentNetwork->allNodes.clear(); currentNetwork->rootNode.reset(); } for(std::vector<char*>::iterator i = allocatedStrings.begin(); i != allocatedStrings.end(); i++) delete[] *i; if(hasError) { error(errString.c_str()); return R_NilValue; } return result; }
SEXP lik4bin(SEXP data, SEXP star, SEXP sigma, SEXP thr, SEXP var, SEXP power, SEXP restringi, SEXP tsp) { double *Pdata, *Psigma, *Pstar, Pres[22], *Rres, *wstar, *age1, *age2; double *Teff, *logg, *z, *M, *R, *Dni, *nimax, *logage, *pcage; double Vthr, maxL, maxL1, maxL2, lmult, EXP, rpcage; long nrow, ncol, count; double sq2pi, chi[NVAR], locsigma[NVAR], chi2, mult, L, mass, radius, lt, ltnlog;; double sTeffP, sTeffM, time1, time2; SEXP res, dm, sel; long i, j, nres, nres1, nres2, DIM, start, n, startT, stopT, up, low; int ii, norun, nstar, *Psel, *Pvar, restr; DATA5 *d, *d1, *d2, *d3, *d4; long lb, ub; double t_spread; // max diff. in age // cast and pointers PROTECT(data = AS_NUMERIC(data)); PROTECT(star = AS_NUMERIC(star)); PROTECT(sigma = AS_NUMERIC(sigma)); PROTECT(thr = AS_NUMERIC(thr)); PROTECT(var = AS_INTEGER(var)); PROTECT(power = AS_NUMERIC(power)); PROTECT(restringi = AS_INTEGER(restringi)); PROTECT(tsp = AS_NUMERIC(tsp)); Pdata = NUMERIC_POINTER(data); Pstar = NUMERIC_POINTER(star); Psigma = NUMERIC_POINTER(sigma); Vthr = NUMERIC_VALUE(thr); Pvar = INTEGER_POINTER(var); EXP = NUMERIC_VALUE(power); restr = NUMERIC_VALUE(restringi); t_spread = NUMERIC_VALUE(tsp); // sqrt ( 2 * pi ) sq2pi = 2.506628274631000; // dataset dimensions nrow = INTEGER(GET_DIM(data))[0]; ncol = INTEGER(GET_DIM(data))[1]; // column pointers // data are column ordered! Teff = Pdata; logg = Pdata+nrow; z = Pdata+2*nrow; Dni = Pdata+3*nrow; nimax = Pdata+4*nrow; M = Pdata+5*nrow; R = Pdata+6*nrow; logage = Pdata+7*nrow; pcage = Pdata+8*nrow; // vector for likelihood computations // 1 = include; 0 = exclude Psel = (int*)malloc(nrow*sizeof(int)); for(nstar=0;nstar<2;nstar++) { for(j=0;j<nrow;j++) Psel[j] = 0; wstar = &Pstar[(nstar)*9]; // sigma scaling for Dni,nimax,M,R (it is a % in input) for(n=0;n<NVAR;n++) locsigma[n] = Psigma[n+NVAR*nstar]; for(n=3;n<7;n++) locsigma[n] *= wstar[n]; mult = 1; for(n=0;n<NVAR;n++) if(Pvar[n] == 1) mult *= 1.0/(sq2pi * locsigma[n]); lmult = log(mult); // allowed Teff interval sTeffP = wstar[0] + Vthr*locsigma[0]; sTeffM = wstar[0] - Vthr*locsigma[0]; // ricerca righe con Teff minima e massima findrange(Teff, nrow, sTeffM, sTeffP, &startT, &stopT); if(startT == -1 || stopT == -1) { free(Psel); UNPROTECT(8); return(R_NilValue); } // sel computation nres = 0; for(j=startT;j<=stopT;j++) { for(ii=0;ii<NVAR;ii++) chi[ii] = 0; if(Pvar[0] == 1) chi[0] = (Teff[j] - wstar[0])/locsigma[0]; if(Pvar[1] == 1) chi[1] = (logg[j] - wstar[1])/locsigma[1]; if(Pvar[2] == 1) chi[2] = (z[j] - wstar[2])/locsigma[2]; if(Pvar[3] == 1) chi[3] = (Dni[j] - wstar[3])/locsigma[3]; if(Pvar[4] == 1) chi[4] = (nimax[j] - wstar[4])/locsigma[4]; if(Pvar[5] == 1) chi[5] = (M[j] - wstar[5])/locsigma[5]; if(Pvar[6] == 1) chi[6] = (R[j] - wstar[6])/locsigma[6]; norun = 0; for(ii=0;ii<NVAR;ii++) { if(fabs(chi[ii]) >= Vthr) { norun = 1; break; } } if( norun == 0 ) { chi2 = 0; for(ii=0;ii<NVAR;ii++) chi2 += chi[ii]*chi[ii]; if( restr == 1 ) { if(sqrt(chi2) <= 3 ) { nres++; Psel[j] = 1; } } else { nres++; Psel[j] = 1; } } } // no data! return if(nres == 0) { free(Psel); UNPROTECT(8); return(R_NilValue); } // init output matrix DIM = nres; if(nstar == 0) { d1 = (DATA5 *)calloc(DIM+1, sizeof(DATA5)); d = d1; } else { d2 = (DATA5 *)calloc(DIM+1, sizeof(DATA5)); d = d2; } // compute lik only if sel = 1 nres = 0; maxL = 0; for(j=startT;j<=stopT;j++) { if( Psel[j] == 1 ) { for(ii=0;ii<NVAR;ii++) chi[ii] = 0; if(Pvar[0] == 1) chi[0] = (Teff[j] - wstar[0])/locsigma[0]; if(Pvar[1] == 1) chi[1] = (logg[j] - wstar[1])/locsigma[1]; if(Pvar[2] == 1) chi[2] = (z[j] - wstar[2])/locsigma[2]; if(Pvar[3] == 1) chi[3] = (Dni[j] - wstar[3])/locsigma[3]; if(Pvar[4] == 1) chi[4] = (nimax[j] - wstar[4])/locsigma[4]; if(Pvar[5] == 1) chi[5] = (M[j] - wstar[5])/locsigma[5]; if(Pvar[6] == 1) chi[6] = (R[j] - wstar[6])/locsigma[6]; chi2 = 0; for(n=0;n<NVAR;n++) chi2 += chi[n]*chi[n]; // likelihood L = mult * exp(-0.5*chi2); if(L > maxL) maxL = L; d[nres].L = L; d[nres].M = M[j]; d[nres].R = R[j]; d[nres].logage = logage[j]; d[nres].pcage = pcage[j]; nres++; } } if(nstar==0) { nres1 = nres; maxL1 = maxL; } else { nres2 = nres; maxL2 = maxL; } } // independent estimates for(nstar=0;nstar<2;nstar++) { mass = radius = lt = ltnlog = rpcage = 0; count = 0; if(nstar==0) { nres = nres1; maxL = maxL1; d = d1; } else { nres = nres2; maxL = maxL2; d = d2; } // select only points with L >= 0.95 maxL for(j=0;j<nres;j++) { if(d[j].L >= 0.95*maxL) { mass += d[j].M; radius += d[j].R; lt += d[j].logage; rpcage += d[j].pcage; ltnlog += 1e-9*pow(10, d[j].logage); count++; } } mass /= (double)(count); radius /= (double)(count); lt /= (double)(count); ltnlog /= (double)(count); rpcage /= (double)(count); Pres[0+6*nstar] = mass; Pres[1+6*nstar] = radius; Pres[2+6*nstar] = lt; Pres[3+6*nstar] = ltnlog; Pres[4+6*nstar] = maxL; Pres[5+6*nstar] = rpcage; } // joint estimates qsort(d2, nres2, sizeof(DATA5), orderage); age2 = (double*)malloc(nres2*sizeof(double)); age1 = (double*)malloc(nres1*sizeof(double)); for(i=0;i<nres1;i++) age1[i] = 1e-9*pow(10, d1[i].logage); for(i=0;i<nres2;i++) age2[i] = 1e-9*pow(10, d2[i].logage); maxL = 0; for(j=0;j<nres1;j++) { findrange(age2, nres2, age1[j]-t_spread,age1[j]+t_spread, &lb, &ub); // the joint estimate is impossible if(lb == -1 || ub == -1) continue; if(lb == ub && fabs(age1[j] - age2[lb]) > t_spread) continue; for(i=lb;i<=ub;i++) { count++; L = d1[j].L * d2[i].L; if(L > maxL) maxL = L; } } for(j=12;j<22;j++) Pres[j] = 0; count = 0; for(j=0;j<nres1;j++) { findrange(age2, nres2, age1[j]-t_spread,age1[j]+t_spread, &lb, &ub); if(lb == -1 || ub == -1) continue; if(lb == ub && fabs(age1[j] - age2[lb]) > t_spread) continue; for(i=lb;i<=ub;i++) { L = d1[j].L * d2[i].L; if(L > 0.95*maxL) { Pres[12] += d1[j].M; Pres[13] += d1[j].R; Pres[14] += d1[j].logage; Pres[15] += age1[j]; Pres[16] += d2[i].M; Pres[17] += d2[i].R; Pres[18] += d2[i].logage; Pres[19] += age2[i]; Pres[21] += d1[j].pcage; count++; } } } Pres[20] = (double)count; for(j=12;j<20;j++) Pres[j] /= (double)(count); Pres[21] /= (double)(count); PROTECT( res = NEW_NUMERIC(22) ); Rres = NUMERIC_POINTER(res); for(j=0;j<22;j++) Rres[j] = Pres[j]; free(d1); free(d2); free(Psel); free(age1); free(age2); // exit UNPROTECT(9); return(res); }
SEXP gridInGrid(SEXP Rptr){ SEXP ans=PROTECT( allocVector(LGLSXP,1) ); ElGridInGrid( toGrid(Rptr), (bool *)LOGICAL(ans) ); UNPROTECT(1); return ans; }
SEXP non_duplicates (SEXP x_, SEXP fromLast_) { int fromLast = asLogical(fromLast_), i, d=0, len = length(x_); int *x_int; double *x_real; SEXP duplicates; int *duplicates_int; PROTECT(duplicates = allocVector(INTSXP, len)); /* possibly resize this */ duplicates_int = INTEGER(duplicates); if(!fromLast) { /* keep first observation */ duplicates_int[0] = ++d; switch(TYPEOF(x_)) { case INTSXP: x_int = INTEGER(x_); for(i=1; i < len-1; i++) { if( x_int[i-1] != x_int[i]) { #ifdef DEBUG Rprintf("i=%i: x[i-1]=%i, x[i]=%i\n",i,x_int[i-1],x_int[i]); #endif duplicates_int[d++] = i+1; } } break; case REALSXP: x_real = REAL(x_); for(i=1; i < len; i++) { /* if( x_real[i-1] == x_real[i]) duplicates_int[d++] = (int)(-1*(i+1)); */ if( x_real[i-1] != x_real[i]) duplicates_int[d++] = i+1; } break; default: error("only numeric types supported"); break; } } else { /* keep last observation */ switch(TYPEOF(x_)) { case INTSXP: x_int = INTEGER(x_); for(i=1; i < len; i++) { if( x_int[i-1] != x_int[i]) duplicates_int[d++] = i; } break; case REALSXP: x_real = REAL(x_); for(i=1; i < len; i++) { if( x_real[i-1] != x_real[i]) duplicates_int[d++] = i; } break; default: error("only numeric types supported"); break; } duplicates_int[d++] = len; } UNPROTECT(1); return(lengthgets(duplicates, d)); }