static void CG_LCP (int m, int nb, dRealMutablePtr J, int *jb, dxBody * const *body, dRealPtr invI, dRealMutablePtr lambda, dRealMutablePtr fc, dRealMutablePtr b, dRealMutablePtr lo, dRealMutablePtr hi, dRealPtr cfm, int *findex, dxQuickStepParameters *qs) { int i,j; const int num_iterations = qs->num_iterations; // precompute iMJ = inv(M)*J' dRealAllocaArray (iMJ,m*12); compute_invM_JT (m,J,iMJ,jb,body,invI); dReal last_rho = 0; dRealAllocaArray (r,m); dRealAllocaArray (z,m); dRealAllocaArray (p,m); dRealAllocaArray (q,m); // precompute 1 / diagonals of A dRealAllocaArray (Ad,m); dRealPtr iMJ_ptr = iMJ; dRealPtr J_ptr = J; for (i=0; i<m; i++) { dReal sum = 0; for (j=0; j<6; j++) sum += iMJ_ptr[j] * J_ptr[j]; if (jb[i*2+1] >= 0) { for (j=6; j<12; j++) sum += iMJ_ptr[j] * J_ptr[j]; } iMJ_ptr += 12; J_ptr += 12; Ad[i] = REAL(1.0) / (sum + cfm[i]); } #ifdef WARM_STARTING // compute residual r = b - A*lambda multiply_J_invM_JT (m,nb,J,iMJ,jb,cfm,fc,lambda,r); for (i=0; i<m; i++) r[i] = b[i] - r[i]; #else dSetZero (lambda,m); memcpy (r,b,m*sizeof(dReal)); // residual r = b - A*lambda #endif for (int iteration=0; iteration < num_iterations; iteration++) { for (i=0; i<m; i++) z[i] = r[i]*Ad[i]; // z = inv(M)*r dReal rho = dot (m,r,z); // rho = r'*z // @@@ // we must check for convergence, otherwise rho will go to 0 if // we get an exact solution, which will introduce NaNs into the equations. if (rho < 1e-10) { printf ("CG returned at iteration %d\n",iteration); break; } if (iteration==0) { memcpy (p,z,m*sizeof(dReal)); // p = z } else { add (m,p,z,p,rho/last_rho); // p = z + (rho/last_rho)*p } // compute q = (J*inv(M)*J')*p multiply_J_invM_JT (m,nb,J,iMJ,jb,cfm,fc,p,q); dReal alpha = rho/dot (m,p,q); // alpha = rho/(p'*q) add (m,lambda,lambda,p,alpha); // lambda = lambda + alpha*p add (m,r,r,q,-alpha); // r = r - alpha*q last_rho = rho; } // compute fc = inv(M)*J'*lambda multiply_invM_JT (m,nb,iMJ,jb,lambda,fc); #if 0 // measure solution error multiply_J_invM_JT (m,nb,J,iMJ,jb,cfm,fc,lambda,r); dReal error = 0; for (i=0; i<m; i++) error += dFabs(r[i] - b[i]); printf ("lambda error = %10.6e\n",error); #endif }
/* 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); }
void fft6(t_fft *x, int n1, int N1, int r, t_fft *t, int dir) { int i = r+n1; real *x0 = x[i]; i+=N1; real *x1 = x[i]; i+=N1; real *x2 = x[i]; i+=N1; real *x3 = x[i]; i+=N1; real *x4 = x[i]; i+=N1; real *x5 = x[i]; real za00 = x2[0] + x4[0]; real za01 = x2[1] + x4[1]; real za10 = x0[0] - T601*za00; real za11 = x0[1] - T601*za01; real za20; real za21; if(dir==1) { za20 = T600*(x4[0] - x2[0]); za21 = T600*(x4[1] - x2[1]); } else { za20 = T600*(x2[0] - x4[0]); za21 = T600*(x2[1] - x4[1]); } real a00 = x0[0] + za00; real a01 = x0[1] + za01; real a10 = za10 - za21; real a11 = za11 + za20; real a20 = za10 + za21; real a21 = za11 - za20; real zb00 = x1[0] + x5[0]; real zb01 = x1[1] + x5[1]; real zb10 = x3[0] - T601*zb00; real zb11 = x3[1] - T601*zb01; real zb20; real zb21; if(dir==1) { zb20 = T600*(x1[0] - x5[0]); zb21 = T600*(x1[1] - x5[1]); } else { zb20 = T600*(x5[0] - x1[0]); zb21 = T600*(x5[1] - x1[1]); } real b00 = x3[0] + zb00; real b01 = x3[1] + zb01; real b10 = zb10 - zb21; real b11 = zb11 + zb20; real b20 = zb10 + zb21; real b21 = zb11 - zb20; x0[0] = a00 + b00; x0[1] = a01 + b01; real y10 = a10 - b10; real y11 = a11 - b11; real *t1 = t[n1]; real t10 = t1[0]; real t11 = t1[1]; x1[0] = REAL(t10,t11,y10,y11); x1[1] = IMAG(t10,t11,y10,y11); real y20 = a20 + b20; real y21 = a21 + b21; real *t2 = t[n1<<1]; real t20 = t2[0]; real t21 = t2[1]; x2[0] = REAL(t20,t21,y20,y21); x2[1] = IMAG(t20,t21,y20,y21); real y30 = a00 - b00; real y31 = a01 - b01; real *t3 = t[n1*3]; real t30 = t3[0]; real t31 = t3[1]; x3[0] = REAL(t30,t31,y30,y31); x3[1] = IMAG(t30,t31,y30,y31); real y40 = a10 + b10; real y41 = a11 + b11; real *t4 = t[n1<<2]; real t40 = t4[0]; real t41 = t4[1]; x4[0] = REAL(t40,t41,y40,y41); x4[1] = IMAG(t40,t41,y40,y41); real y50 = a20 - b20; real y51 = a21 - b21; real *t5 = t[n1*5]; real t50 = t5[0]; real t51 = t5[1]; x5[0] = REAL(t50,t51,y50,y51); x5[1] = IMAG(t50,t51,y50,y51); }
int dCollideRTL(dxGeom* g1, dxGeom* RayGeom, int Flags, dContactGeom* Contacts, int Stride){ dIASSERT (Stride >= (int)sizeof(dContactGeom)); dIASSERT (g1->type == dTriMeshClass); dIASSERT (RayGeom->type == dRayClass); dIASSERT ((Flags & NUMC_MASK) >= 1); dxTriMesh* TriMesh = (dxTriMesh*)g1; const dVector3& TLPosition = *(const dVector3*)dGeomGetPosition(TriMesh); const dMatrix3& TLRotation = *(const dMatrix3*)dGeomGetRotation(TriMesh); const unsigned uiTLSKind = TriMesh->getParentSpaceTLSKind(); dIASSERT(uiTLSKind == RayGeom->getParentSpaceTLSKind()); // The colliding spaces must use matching cleanup method TrimeshCollidersCache *pccColliderCache = GetTrimeshCollidersCache(uiTLSKind); RayCollider& Collider = pccColliderCache->_RayCollider; dReal Length = dGeomRayGetLength(RayGeom); int FirstContact, BackfaceCull; dGeomRayGetParams(RayGeom, &FirstContact, &BackfaceCull); int ClosestHit = dGeomRayGetClosestHit(RayGeom); Collider.SetFirstContact(FirstContact != 0); Collider.SetClosestHit(ClosestHit != 0); Collider.SetCulling(BackfaceCull != 0); Collider.SetMaxDist(Length); dVector3 Origin, Direction; dGeomRayGet(RayGeom, Origin, Direction); /* Make Ray */ Ray WorldRay; WorldRay.mOrig.x = Origin[0]; WorldRay.mOrig.y = Origin[1]; WorldRay.mOrig.z = Origin[2]; WorldRay.mDir.x = Direction[0]; WorldRay.mDir.y = Direction[1]; WorldRay.mDir.z = Direction[2]; /* Intersect */ Matrix4x4 amatrix; int TriCount = 0; if (Collider.Collide(WorldRay, TriMesh->Data->BVTree, &MakeMatrix(TLPosition, TLRotation, amatrix))) { TriCount = pccColliderCache->Faces.GetNbFaces(); } if (TriCount == 0) { return 0; } const CollisionFace* Faces = pccColliderCache->Faces.GetFaces(); int OutTriCount = 0; for (int i = 0; i < TriCount; i++) { if (TriMesh->RayCallback == null || TriMesh->RayCallback(TriMesh, RayGeom, Faces[i].mFaceID, Faces[i].mU, Faces[i].mV)) { const int& TriIndex = Faces[i].mFaceID; if (!Callback(TriMesh, RayGeom, TriIndex)) { continue; } dContactGeom* Contact = SAFECONTACT(Flags, Contacts, OutTriCount, Stride); dVector3 dv[3]; FetchTriangle(TriMesh, TriIndex, TLPosition, TLRotation, dv); dVector3 vu; vu[0] = dv[1][0] - dv[0][0]; vu[1] = dv[1][1] - dv[0][1]; vu[2] = dv[1][2] - dv[0][2]; vu[3] = REAL(0.0); dVector3 vv; vv[0] = dv[2][0] - dv[0][0]; vv[1] = dv[2][1] - dv[0][1]; vv[2] = dv[2][2] - dv[0][2]; vv[3] = REAL(0.0); dCalcVectorCross3(Contact->normal, vv, vu); // Reversed // Even though all triangles might be initially valid, // a triangle may degenerate into a segment after applying // space transformation. if (dSafeNormalize3(Contact->normal)) { // No sense to save on single type conversion in algorithm of this size. // If there would be a custom typedef for distance type it could be used // instead of dReal. However using float directly is the loss of abstraction // and possible loss of precision in future. /*float*/ dReal T = Faces[i].mDistance; Contact->pos[0] = Origin[0] + (Direction[0] * T); Contact->pos[1] = Origin[1] + (Direction[1] * T); Contact->pos[2] = Origin[2] + (Direction[2] * T); Contact->pos[3] = REAL(0.0); Contact->depth = T; Contact->g1 = TriMesh; Contact->g2 = RayGeom; Contact->side1 = TriIndex; Contact->side2 = -1; OutTriCount++; // Putting "break" at the end of loop prevents unnecessary checks on first pass and "continue" if (OutTriCount >= (Flags & NUMC_MASK)) { break; } } } } return OutTriCount; }
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); }
/** * Define variables and write data */ SEXP R_write(SEXP R_filename, SEXP R_group, SEXP R_groupname, SEXP R_nvars, // number of vars SEXP R_varname_list, // var names SEXP R_var_list, // var values SEXP R_varlength_list, // length of var values SEXP R_ndim, // number of dims SEXP R_type, SEXP R_comm, SEXP R_p, SEXP R_adios_rank) { const char *filename = CHARPT(R_filename, 0); int64_t m_adios_group = (int64_t)(REAL(R_group)[0]); const char *groupname = CHARPT(R_groupname, 0); int nvars = asInteger(R_nvars); MPI_Comm comm = MPI_Comm_f2c(INTEGER(R_comm)[0]); int size = asInteger(R_p); int rank = asInteger(R_adios_rank); int i, j; int Global_bounds, Offsets; uint64_t adios_groupsize, adios_totalsize; int64_t m_adios_file; // variable to store the value converted from integer char str[256]; // Define variables for(i = 0; i < nvars; i++) { const char *varname = CHAR(asChar(VECTOR_ELT(R_varname_list,i))); int *length = INTEGER(VECTOR_ELT(R_varlength_list, i)); int *vndim = INTEGER(VECTOR_ELT(R_ndim, i)); int *typetag = INTEGER(VECTOR_ELT(R_type, i)); if((length[0] == 1) && (vndim[0] == 1)){ // scalar if(typetag[0] == 0) { adios_define_var (m_adios_group, varname, "", adios_integer, 0, 0, 0); }else { adios_define_var (m_adios_group, varname, "", adios_double, 0, 0, 0); } }else { // define dimensions, global_dimensions, local_offsets and the variable int temp_var_length = strlen(varname) + 8; char* local_var = (char*)malloc(vndim[0]*temp_var_length); char* global_var = (char*)malloc(vndim[0]*temp_var_length); char* offset_var = (char*)malloc(vndim[0]*temp_var_length); // initialize char variables strcpy(local_var, ""); strcpy(global_var, ""); strcpy(offset_var, ""); // j = 0 j = 0; sprintf(str, "%d", j); char* local = (char*)malloc(temp_var_length); strcpy(local, varname); strcat(local, "_nx_"); strcat(local, str); strcat(local_var, local); char* global = (char*)malloc(temp_var_length); strcpy(global, varname); strcat(global, "_gx_"); strcat(global, str); strcat(global_var, global); char* offset = (char*)malloc(temp_var_length); strcpy(offset, varname); strcat(offset, "_off_"); strcat(offset, str); strcat(offset_var, offset); // define local dim, global dim and offset for each dimension adios_define_var (m_adios_group, local, "", adios_integer, 0, 0, 0); adios_define_var (m_adios_group, global, "", adios_integer, 0, 0, 0); adios_define_var (m_adios_group, offset, "", adios_integer, 0, 0, 0); Free(local); Free(global); Free(offset); for(j = 1; j < vndim[0]; j++) { sprintf(str, "%d", j); strcat(local_var, ","); char* local = (char*)malloc(temp_var_length); strcpy(local, varname); strcat(local, "_nx_"); strcat(local, str); strcat(local_var, local); strcat(global_var, ","); char* global = (char*)malloc(temp_var_length); strcpy(global, varname); strcat(global, "_gx_"); strcat(global, str); strcat(global_var, global); strcat(offset_var, ","); char* offset = (char*)malloc(temp_var_length); strcpy(offset, varname); strcat(offset, "_off_"); strcat(offset, str); strcat(offset_var, offset); // define local dim, global dim and offset for each dimension adios_define_var (m_adios_group, local, "", adios_integer, 0, 0, 0); adios_define_var (m_adios_group, global, "", adios_integer, 0, 0, 0); adios_define_var (m_adios_group, offset, "", adios_integer, 0, 0, 0); Free(local); Free(global); Free(offset); } // define variable if(typetag[0] == 0) { adios_define_var (m_adios_group, varname, "", adios_integer, local_var, global_var, offset_var); }else { adios_define_var (m_adios_group, varname, "", adios_double, local_var, global_var, offset_var); } Free(local_var); Free(global_var); Free(offset_var); } } // Open ADIOS adios_open (&m_adios_file, groupname, filename, "w", comm); adios_groupsize = 0; for(i = 0; i < nvars; i++) { int *length = INTEGER(VECTOR_ELT(R_varlength_list, i)); int *vndim = INTEGER(VECTOR_ELT(R_ndim, i)); int *typetag = INTEGER(VECTOR_ELT(R_type, i)); // calculate the length of the variable int temp = 1; for(j = 0; j < vndim[0]; j++) temp *= length[j]; if((length[0] == 1) && (vndim[0] == 1)){ // scalar if(typetag[0] == 0) { adios_groupsize += 4; }else { adios_groupsize += 8; } }else { if(typetag[0] == 0) { adios_groupsize += (12 * vndim[0] + temp * 4); }else { adios_groupsize += (12 * vndim[0] + temp * 8); } } } adios_group_size (m_adios_file, adios_groupsize, &adios_totalsize); // Write data into variables for(i = 0; i < nvars; i++) { const char *varname = CHAR(asChar(VECTOR_ELT(R_varname_list,i))); int *length = INTEGER(VECTOR_ELT(R_varlength_list, i)); int *vndim = INTEGER(VECTOR_ELT(R_ndim, i)); int *typetag = INTEGER(VECTOR_ELT(R_type, i)); if((length[0] == 1) && (vndim[0] == 1)){ // scalar }else { // var int temp_var_length = strlen(varname) + 8; j = 0; sprintf(str, "%d", j); char* local = (char*)malloc(temp_var_length); strcpy(local, varname); strcat(local, "_nx_"); strcat(local, str); char* global = (char*)malloc(temp_var_length); strcpy(global, varname); strcat(global, "_gx_"); strcat(global, str); char* offset = (char*)malloc(temp_var_length); strcpy(offset, varname); strcat(offset, "_off_"); strcat(offset, str); adios_write(m_adios_file, local, (void *) &(length[j])); Global_bounds = length[j] * size; adios_write(m_adios_file, global, (void *) &Global_bounds); Offsets = rank * length[j]; adios_write(m_adios_file, offset, (void *) &Offsets); Free(local); Free(global); Free(offset); for(j = 1; j < vndim[0]; j++) { sprintf(str, "%d", j); char* local = (char*)malloc(temp_var_length); strcpy(local, varname); strcat(local, "_nx_"); strcat(local, str); char* global = (char*)malloc(temp_var_length); strcpy(global, varname); strcat(global, "_gx_"); strcat(global, str); char* offset = (char*)malloc(temp_var_length); strcpy(offset, varname); strcat(offset, "_off_"); strcat(offset, str); adios_write(m_adios_file, local, (void *) &(length[j])); Global_bounds = length[j]; adios_write(m_adios_file, global, (void *) &Global_bounds); Offsets = 0; adios_write(m_adios_file, offset, (void *) &Offsets); Free(local); Free(global); Free(offset); } } // write var data if(typetag[0] == 0) { adios_write(m_adios_file, varname, (void *) INTEGER(VECTOR_ELT(R_var_list, i))); }else { adios_write(m_adios_file, varname, (void *) REAL(VECTOR_ELT(R_var_list, i))); } } adios_close (m_adios_file); MPI_Barrier (comm); return R_NilValue; }
static inline double * Cast( SEXP Rvec ) { assert(Rvec); return REAL(Rvec); }
static void klu_l_demo (Long n, Long *Ap, Long *Ai, double *Ax, Long isreal) { double rnorm ; klu_l_common Common ; double *B, *X, *R ; Long i, lunz ; printf ("KLU: %s, version: %d.%d.%d\n", KLU_DATE, KLU_MAIN_VERSION, KLU_SUB_VERSION, KLU_SUBSUB_VERSION) ; /* ---------------------------------------------------------------------- */ /* set defaults */ /* ---------------------------------------------------------------------- */ klu_l_defaults (&Common) ; /* ---------------------------------------------------------------------- */ /* create a right-hand-side */ /* ---------------------------------------------------------------------- */ if (isreal) { /* B = 1 + (1:n)/n */ B = klu_l_malloc (n, sizeof (double), &Common) ; X = klu_l_malloc (n, sizeof (double), &Common) ; R = klu_l_malloc (n, sizeof (double), &Common) ; if (B) { for (i = 0 ; i < n ; i++) { B [i] = 1 + ((double) i+1) / ((double) n) ; } } } else { /* real (B) = 1 + (1:n)/n, imag(B) = (n:-1:1)/n */ B = klu_l_malloc (n, 2 * sizeof (double), &Common) ; X = klu_l_malloc (n, 2 * sizeof (double), &Common) ; R = klu_l_malloc (n, 2 * sizeof (double), &Common) ; if (B) { for (i = 0 ; i < n ; i++) { REAL (B, i) = 1 + ((double) i+1) / ((double) n) ; IMAG (B, i) = ((double) n-i) / ((double) n) ; } } } /* ---------------------------------------------------------------------- */ /* X = A\b using KLU and print statistics */ /* ---------------------------------------------------------------------- */ if (!klu_l_backslash (n, Ap, Ai, Ax, isreal, B, X, R, &lunz, &rnorm, &Common)) { printf ("KLU failed\n") ; } else { printf ("n %ld nnz(A) %ld nnz(L+U+F) %ld resid %g\n" "recip growth %g condest %g rcond %g flops %g\n", n, Ap [n], lunz, rnorm, Common.rgrowth, Common.condest, Common.rcond, Common.flops) ; } /* ---------------------------------------------------------------------- */ /* free the problem */ /* ---------------------------------------------------------------------- */ if (isreal) { klu_l_free (B, n, sizeof (double), &Common) ; klu_l_free (X, n, sizeof (double), &Common) ; klu_l_free (R, n, sizeof (double), &Common) ; } else { klu_l_free (B, 2*n, sizeof (double), &Common) ; klu_l_free (X, 2*n, sizeof (double), &Common) ; klu_l_free (R, 2*n, sizeof (double), &Common) ; } printf ("peak memory usage: %g bytes\n\n", (double) (Common.mempeak)) ; }
static Long klu_l_backslash /* return 1 if successful, 0 otherwise */ ( /* --- input ---- */ Long n, /* A is n-by-n */ Long *Ap, /* size n+1, column pointers */ Long *Ai, /* size nz = Ap [n], row indices */ double *Ax, /* size nz, numerical values */ Long isreal, /* nonzero if A is real, 0 otherwise */ double *B, /* size n, right-hand-side */ /* --- output ---- */ double *X, /* size n, solution to Ax=b */ double *R, /* size n, residual r = b-A*x */ /* --- scalar output --- */ Long *lunz, /* nnz (L+U+F) */ double *rnorm, /* norm (b-A*x,1) / norm (A,1) */ /* --- workspace - */ klu_l_common *Common /* default parameters and statistics */ ) { double anorm = 0, asum ; klu_l_symbolic *Symbolic ; klu_l_numeric *Numeric ; Long i, j, p ; if (!Ap || !Ai || !Ax || !B || !X || !B) return (0) ; /* ---------------------------------------------------------------------- */ /* symbolic ordering and analysis */ /* ---------------------------------------------------------------------- */ Symbolic = klu_l_analyze (n, Ap, Ai, Common) ; if (!Symbolic) return (0) ; if (isreal) { /* ------------------------------------------------------------------ */ /* factorization */ /* ------------------------------------------------------------------ */ Numeric = klu_l_factor (Ap, Ai, Ax, Symbolic, Common) ; if (!Numeric) { klu_l_free_symbolic (&Symbolic, Common) ; return (0) ; } /* ------------------------------------------------------------------ */ /* statistics (not required to solve Ax=b) */ /* ------------------------------------------------------------------ */ klu_l_rgrowth (Ap, Ai, Ax, Symbolic, Numeric, Common) ; klu_l_condest (Ap, Ax, Symbolic, Numeric, Common) ; klu_l_rcond (Symbolic, Numeric, Common) ; klu_l_flops (Symbolic, Numeric, Common) ; *lunz = Numeric->lnz + Numeric->unz - n + ((Numeric->Offp) ? (Numeric->Offp [n]) : 0) ; /* ------------------------------------------------------------------ */ /* solve Ax=b */ /* ------------------------------------------------------------------ */ for (i = 0 ; i < n ; i++) { X [i] = B [i] ; } klu_l_solve (Symbolic, Numeric, n, 1, X, Common) ; /* ------------------------------------------------------------------ */ /* compute residual, rnorm = norm(b-Ax,1) / norm(A,1) */ /* ------------------------------------------------------------------ */ for (i = 0 ; i < n ; i++) { R [i] = B [i] ; } for (j = 0 ; j < n ; j++) { asum = 0 ; for (p = Ap [j] ; p < Ap [j+1] ; p++) { /* R (i) -= A (i,j) * X (j) */ R [Ai [p]] -= Ax [p] * X [j] ; asum += fabs (Ax [p]) ; } anorm = MAX (anorm, asum) ; } *rnorm = 0 ; for (i = 0 ; i < n ; i++) { *rnorm = MAX (*rnorm, fabs (R [i])) ; } /* ------------------------------------------------------------------ */ /* free numeric factorization */ /* ------------------------------------------------------------------ */ klu_l_free_numeric (&Numeric, Common) ; } else { /* ------------------------------------------------------------------ */ /* statistics (not required to solve Ax=b) */ /* ------------------------------------------------------------------ */ Numeric = klu_zl_factor (Ap, Ai, Ax, Symbolic, Common) ; if (!Numeric) { klu_l_free_symbolic (&Symbolic, Common) ; return (0) ; } /* ------------------------------------------------------------------ */ /* statistics */ /* ------------------------------------------------------------------ */ klu_zl_rgrowth (Ap, Ai, Ax, Symbolic, Numeric, Common) ; klu_zl_condest (Ap, Ax, Symbolic, Numeric, Common) ; klu_zl_rcond (Symbolic, Numeric, Common) ; klu_zl_flops (Symbolic, Numeric, Common) ; *lunz = Numeric->lnz + Numeric->unz - n + ((Numeric->Offp) ? (Numeric->Offp [n]) : 0) ; /* ------------------------------------------------------------------ */ /* solve Ax=b */ /* ------------------------------------------------------------------ */ for (i = 0 ; i < 2*n ; i++) { X [i] = B [i] ; } klu_zl_solve (Symbolic, Numeric, n, 1, X, Common) ; /* ------------------------------------------------------------------ */ /* compute residual, rnorm = norm(b-Ax,1) / norm(A,1) */ /* ------------------------------------------------------------------ */ for (i = 0 ; i < 2*n ; i++) { R [i] = B [i] ; } for (j = 0 ; j < n ; j++) { asum = 0 ; for (p = Ap [j] ; p < Ap [j+1] ; p++) { /* R (i) -= A (i,j) * X (j) */ i = Ai [p] ; REAL (R,i) -= REAL(Ax,p) * REAL(X,j) - IMAG(Ax,p) * IMAG(X,j) ; IMAG (R,i) -= IMAG(Ax,p) * REAL(X,j) + REAL(Ax,p) * IMAG(X,j) ; asum += CABS (Ax, p) ; } anorm = MAX (anorm, asum) ; } *rnorm = 0 ; for (i = 0 ; i < n ; i++) { *rnorm = MAX (*rnorm, CABS (R, i)) ; } /* ------------------------------------------------------------------ */ /* free numeric factorization */ /* ------------------------------------------------------------------ */ klu_zl_free_numeric (&Numeric, Common) ; } /* ---------------------------------------------------------------------- */ /* free symbolic analysis, and residual */ /* ---------------------------------------------------------------------- */ klu_l_free_symbolic (&Symbolic, Common) ; return (1) ; }
static SEXP baseCallback(GEevent task, pGEDevDesc dd, SEXP data) { GESystemDesc *sd; baseSystemState *bss, *bss2; SEXP result = R_NilValue; switch (task) { case GE_FinaliseState: /* called from unregisterOne */ sd = dd->gesd[baseRegisterIndex]; free(sd->systemSpecific); sd->systemSpecific = NULL; break; case GE_InitState: { /* called from registerOne */ pDevDesc dev; GPar *ddp; sd = dd->gesd[baseRegisterIndex]; dev = dd->dev; bss = sd->systemSpecific = malloc(sizeof(baseSystemState)); /* Bail out if necessary */ if (!bss) return result; ddp = &(bss->dp); GInit(ddp); /* For some things, the device sets the starting value at least. */ ddp->ps = dev->startps; ddp->col = ddp->fg = dev->startcol; ddp->bg = dev->startfill; ddp->font = dev->startfont; ddp->lty = dev->startlty; ddp->gamma = dev->startgamma; /* Initialise the gp settings too: formerly in addDevice. */ copyGPar(ddp, &(bss->gp)); GReset(dd); /* * The device has not yet received any base output */ bss->baseDevice = FALSE; /* Indicate success */ result = R_BlankString; break; } case GE_CopyState: { /* called from GEcopyDisplayList */ pGEDevDesc curdd = GEcurrentDevice(); bss = dd->gesd[baseRegisterIndex]->systemSpecific; bss2 = curdd->gesd[baseRegisterIndex]->systemSpecific; copyGPar(&(bss->dpSaved), &(bss2->dpSaved)); restoredpSaved(curdd); copyGPar(&(bss2->dp), &(bss2->gp)); GReset(curdd); break; } case GE_SaveState: /* called from GEinitDisplayList */ bss = dd->gesd[baseRegisterIndex]->systemSpecific; copyGPar(&(bss->dp), &(bss->dpSaved)); break; case GE_RestoreState: /* called from GEplayDisplayList */ bss = dd->gesd[baseRegisterIndex]->systemSpecific; restoredpSaved(dd); copyGPar(&(bss->dp), &(bss->gp)); GReset(dd); break; case GE_SaveSnapshotState: /* called from GEcreateSnapshot */ bss = dd->gesd[baseRegisterIndex]->systemSpecific; /* Changed from INTSXP in 2.7.0: but saved graphics lists are protected by an R version number */ PROTECT(result = allocVector(RAWSXP, sizeof(GPar))); copyGPar(&(bss->dpSaved), (GPar*) RAW(result)); UNPROTECT(1); break; case GE_RestoreSnapshotState: /* called from GEplaySnapshot */ bss = dd->gesd[baseRegisterIndex]->systemSpecific; copyGPar((GPar*) RAW(data), &(bss->dpSaved)); restoredpSaved(dd); copyGPar(&(bss->dp), &(bss->gp)); GReset(dd); break; case GE_CheckPlot: /* called from GEcheckState: Check that the current plotting state is "valid" */ bss = dd->gesd[baseRegisterIndex]->systemSpecific; result = ScalarLogical(bss->baseDevice ? (bss->gp.state == 1) && bss->gp.valid : TRUE); break; case GE_ScalePS: { /* called from GEhandleEvent in devWindows.c */ GPar *ddp, *ddpSaved; bss = dd->gesd[baseRegisterIndex]->systemSpecific; ddp = &(bss->dp); ddpSaved = &(bss->dpSaved); if (isReal(data) && LENGTH(data) == 1) { double rf = REAL(data)[0]; ddp->scale *= rf; /* Modify the saved settings so this effects display list too */ ddpSaved->scale *= rf; } else error("event 'GE_ScalePS' requires a single numeric value"); break; } } return result; }
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)); }
/* used in connections.c */ SEXP xlengthgets(SEXP x, R_xlen_t len) { R_xlen_t lenx, i; SEXP rval, names, xnames, t; if (!isVector(x) && !isVectorizable(x)) error(_("cannot set length of non-vector")); lenx = xlength(x); if (lenx == len) return (x); PROTECT(rval = allocVector(TYPEOF(x), len)); PROTECT(xnames = getAttrib(x, R_NamesSymbol)); if (xnames != R_NilValue) names = allocVector(STRSXP, len); else names = R_NilValue; /*- just for -Wall --- should we do this ? */ switch (TYPEOF(x)) { case NILSXP: break; case LGLSXP: case INTSXP: for (i = 0; i < len; i++) if (i < lenx) { INTEGER(rval)[i] = INTEGER(x)[i]; if (xnames != R_NilValue) SET_STRING_ELT(names, i, STRING_ELT(xnames, i)); } else INTEGER(rval)[i] = NA_INTEGER; break; case REALSXP: for (i = 0; i < len; i++) if (i < lenx) { REAL(rval)[i] = REAL(x)[i]; if (xnames != R_NilValue) SET_STRING_ELT(names, i, STRING_ELT(xnames, i)); } else REAL(rval)[i] = NA_REAL; break; case CPLXSXP: for (i = 0; i < len; i++) if (i < lenx) { COMPLEX(rval)[i] = COMPLEX(x)[i]; if (xnames != R_NilValue) SET_STRING_ELT(names, i, STRING_ELT(xnames, i)); } else { COMPLEX(rval)[i].r = NA_REAL; COMPLEX(rval)[i].i = NA_REAL; } break; case STRSXP: for (i = 0; i < len; i++) if (i < lenx) { SET_STRING_ELT(rval, i, STRING_ELT(x, i)); if (xnames != R_NilValue) SET_STRING_ELT(names, i, STRING_ELT(xnames, i)); } else SET_STRING_ELT(rval, i, NA_STRING); break; case LISTSXP: for (t = rval; t != R_NilValue; t = CDR(t), x = CDR(x)) { SETCAR(t, CAR(x)); SET_TAG(t, TAG(x)); } case VECSXP: for (i = 0; i < len; i++) if (i < lenx) { SET_VECTOR_ELT(rval, i, VECTOR_ELT(x, i)); if (xnames != R_NilValue) SET_STRING_ELT(names, i, STRING_ELT(xnames, i)); } break; case RAWSXP: for (i = 0; i < len; i++) if (i < lenx) { RAW(rval)[i] = RAW(x)[i]; if (xnames != R_NilValue) SET_STRING_ELT(names, i, STRING_ELT(xnames, i)); } else RAW(rval)[i] = (Rbyte) 0; break; default: UNIMPLEMENTED_TYPE("length<-", x); } if (isVector(x) && xnames != R_NilValue) setAttrib(rval, R_NamesSymbol, names); UNPROTECT(2); return rval; }
SEXP cliques_R(SEXP net, SEXP sn, SEXP sm, SEXP stabulatebyvert, SEXP scomembership, SEXP senumerate) /*Maximal clique enumeration as an R-callable (.Call) function. net should be an sna edgelist (w/n vertices and m/2 edges), and must be pre-symmetrized. stabulatebyvert should be 0 if no tabulation is to be performed, or 1 for vertex-level tabulation of clique membership. scomembership should be 0 for no co-membership tabulation, 1 for aggregate vertex-by-vertex tabulation, and 2 for size-by-vertex-by-vertex tabulation. Finally, senumerate should be 1 iff the enumerated clique list should be returned. (The current algorithm enumerates them internally, regardless. This is b/c I am lazy, and didn't fold all of the tabulation tasks into the recursion process. Life is hard.)*/ { int n,tabulate,comemb,enumerate,*gotcomp,*compmemb,i,j,k,maxcsize,pc=0; double *ccount,*pccountvec,*pcocliquevec=NULL; snaNet *g; slelement *sep,*sep2,*k0; element **clist,*ep; SEXP smaxcsize,ccountvec,outlist,cliquevec=R_NilValue; SEXP temp=R_NilValue,sp=R_NilValue,cocliquevec=R_NilValue; /*Coerce what needs coercin'*/ PROTECT(sn=coerceVector(sn,INTSXP)); pc++; PROTECT(net=coerceVector(net,REALSXP)); pc++; PROTECT(stabulatebyvert=coerceVector(stabulatebyvert,INTSXP)); pc++; PROTECT(scomembership=coerceVector(scomembership,INTSXP)); pc++; PROTECT(senumerate=coerceVector(senumerate,INTSXP)); pc++; n=INTEGER(sn)[0]; tabulate=INTEGER(stabulatebyvert)[0]; comemb=INTEGER(scomembership)[0]; enumerate=INTEGER(senumerate)[0]; /*Pre-allocate what needs pre-allocatin'*/ ccount=(double *)R_alloc(n,sizeof(double)); PROTECT(smaxcsize=allocVector(INTSXP,1)); pc++; clist=(element **)R_alloc(n,sizeof(element *)); for(i=0;i<n;i++){ ccount[i]=0.0; clist[i]=NULL; } /*Initialize sna internal network*/ GetRNGstate(); g=elMatTosnaNet(REAL(net),INTEGER(sn),INTEGER(sm)); /*Calculate the components of g*/ compmemb=undirComponents(g); /*Accumulate cliques across components*/ gotcomp=(int *)R_alloc(compmemb[0],sizeof(int)); for(i=0;i<compmemb[0];i++) gotcomp[i]=0; for(i=0;i<n;i++) /*Move through vertices in order*/ if(!gotcomp[compmemb[i+1]-1]){ /*Take first vertex of each component*/ gotcomp[compmemb[i+1]-1]++; /*Mark component as visited*/ /*Get the first maximal clique in this component*/ k0=slistInsert(NULL,(double)i,NULL); k0=cliqueFirstChild(g,k0); /*Recursively enumerate all cliques within the component*/ cliqueRecurse(g,k0,i,clist,ccount,compmemb); } PutRNGstate(); /*Find the maximum clique size (to cut down on subsequent memory usage)*/ INTEGER(smaxcsize)[0]=n+1; for(i=n-1;(i>=0)&(INTEGER(smaxcsize)[0]==n+1);i--) if(ccount[i]>0.0) INTEGER(smaxcsize)[0]=i+1; maxcsize=INTEGER(smaxcsize)[0]; /*Allocate memory for R return value objects*/ if(tabulate){ PROTECT(ccountvec=allocVector(REALSXP,maxcsize*(1+n))); pc++; for(i=0;i<maxcsize*(1+n);i++) REAL(ccountvec)[i]=0.0; }else{ PROTECT(ccountvec=allocVector(REALSXP,maxcsize)); pc++; for(i=0;i<maxcsize;i++) REAL(ccountvec)[i]=0.0; } pccountvec=REAL(ccountvec); switch(comemb){ case 0: cocliquevec=R_NilValue; pcocliquevec=NULL; break; case 1: PROTECT(cocliquevec=allocVector(REALSXP,n*n)); pc++; for(i=0;i<n*n;i++) REAL(cocliquevec)[i]=0.0; pcocliquevec=REAL(cocliquevec); break; case 2: PROTECT(cocliquevec=allocVector(REALSXP,maxcsize*n*n)); pc++; for(i=0;i<maxcsize*n*n;i++) REAL(cocliquevec)[i]=0.0; pcocliquevec=REAL(cocliquevec); break; } if(enumerate){ PROTECT(cliquevec=allocVector(VECSXP,maxcsize)); pc++; for(i=0;i<maxcsize;i++){ if(ccount[i]==0.0) SET_VECTOR_ELT(cliquevec,i,R_NilValue); else{ PROTECT(temp=allocVector(VECSXP,(int)(ccount[i]))); SET_VECTOR_ELT(cliquevec,i,temp); UNPROTECT(1); } } } /*Tabulate, enumerate, and other good things*/ for(i=0;i<maxcsize;i++){ pccountvec[i+tabulate*maxcsize*n]=ccount[i]; if(ccount[i]>0.0){ if(enumerate) sp=VECTOR_ELT(cliquevec,i); /*Walk through every clique of size i+1*/ for(j=0,ep=clist[i];ep!=NULL;ep=ep->next){ if(enumerate) PROTECT(temp=allocVector(INTSXP,i+1)); /*Walk through every clique member*/ for(k=0,sep=((slelement *)(ep->dp))->next[0];sep!=NULL; sep=sep->next[0]){ if(enumerate) /*Add to enumeration list*/ INTEGER(temp)[k++]=(int)(sep->val)+1; if(tabulate) /*Add to vertex-by-size tabulation*/ pccountvec[i+maxcsize*((int)(sep->val))]++; switch(comemb){ /*Add co-membership information*/ case 0: /*Case 0 - do nothing*/ break; case 1: /*Case 1 - just co-membership*/ for(sep2=((slelement *)(ep->dp))->next[0];sep2!=sep; sep2=sep2->next[0]){ pcocliquevec[((int)(sep->val))+n*((int)(sep2->val))]++; pcocliquevec[((int)(sep2->val))+n*((int)(sep->val))]++; } pcocliquevec[((int)(sep->val))+n*((int)(sep->val))]++; break; case 2: /*Case 2 - co-membership by size*/ for(sep2=((slelement *)(ep->dp))->next[0];sep2!=sep; sep2=sep2->next[0]){ pcocliquevec[i+maxcsize*((int)(sep->val))+ maxcsize*n*((int)(sep2->val))]++; pcocliquevec[i+maxcsize*((int)(sep2->val))+ maxcsize*n*((int)(sep->val))]++; } pcocliquevec[i+maxcsize*((int)(sep->val))+ maxcsize*n*((int)(sep->val))]++; break; } } if(enumerate){ SET_VECTOR_ELT(sp,j++,temp); UNPROTECT(1); } } } } /*Prepare and return the results*/ PROTECT(outlist=allocVector(VECSXP,4)); pc++; SET_VECTOR_ELT(outlist,0,smaxcsize); SET_VECTOR_ELT(outlist,1,ccountvec); SET_VECTOR_ELT(outlist,2,cocliquevec); SET_VECTOR_ELT(outlist,3,cliquevec); UNPROTECT(pc); return outlist; }
SEXP bicomponents_R(SEXP net, SEXP sn, SEXP sm) { snaNet *g; int *parent,*num,*back,*dfn,i,j,n,count,pc=0; element *complist,*ep,*ep2,*es; SEXP bicomps,bcl,memb,outlist; /*Coerce what needs coercin'*/ //Rprintf("Initial coercion\n"); PROTECT(sn=coerceVector(sn,INTSXP)); pc++; PROTECT(sm=coerceVector(sm,INTSXP)); pc++; PROTECT(net=coerceVector(net,REALSXP)); pc++; n=INTEGER(sn)[0]; /*Initialize sna internal network*/ GetRNGstate(); g=elMatTosnaNet(REAL(net),INTEGER(sn),INTEGER(sm)); /*Calculate the sorting stat*/ parent=(int *)R_alloc(n,sizeof(int)); num=(int *)R_alloc(n,sizeof(int)); back=(int *)R_alloc(n,sizeof(int)); dfn=(int *)R_alloc(1,sizeof(int)); for(i=0;i<n;i++){ parent[i]=-1; num[i]=0; back[i]=n+1; } *dfn=0; /*Initialize the component list*/ complist=(element *)R_alloc(1,sizeof(element)); complist->val=0.0; complist->next=NULL; complist->dp=NULL; /*Walk the graph components, finding bicomponents*/ es=(element *)R_alloc(1,sizeof(element)); for(i=0;i<n;i++) if(num[i]==0){ es->next=NULL; bicomponentRecurse(g,complist,es,parent,num,back,dfn,i); } /*Transfer information from complist to output vector*/ //Rprintf("Gathering components...\n"); count=(int)complist->val; PROTECT(outlist=allocVector(VECSXP,2)); pc++; PROTECT(bicomps=allocVector(VECSXP,count)); pc++; PROTECT(memb=allocVector(INTSXP,n)); pc++; for(i=0;i<n;i++) /*Initialize memberships, since some have none*/ INTEGER(memb)[i]=-1; ep=complist->next; for(i=0;i<count;i++){ PROTECT(bcl=allocVector(INTSXP,(int)ep->val)); j=0; for(ep2=(element *)ep->dp;ep2!=NULL;ep2=ep2->next){ INTEGER(bcl)[j++]=(int)ep2->val+1; INTEGER(memb)[(int)ep2->val]=i+1; } SET_VECTOR_ELT(bicomps,i,bcl); UNPROTECT(1); ep=ep->next; } SET_VECTOR_ELT(outlist,0,bicomps); SET_VECTOR_ELT(outlist,1,memb); /*Unprotect and return*/ PutRNGstate(); UNPROTECT(pc); return outlist; }
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; }
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); }
// xtsExtractSubset {{{ static SEXP xtsExtractSubset(SEXP x, SEXP result, SEXP indx) //, SEXP call) { int i, ii, n, nx, mode; SEXP tmp, tmp2; mode = TYPEOF(x); n = LENGTH(indx); nx = length(x); tmp = result; if (x == R_NilValue) return x; for (i = 0; i < n; i++) { ii = INTEGER(indx)[i]; if (ii != NA_INTEGER) ii--; switch (mode) { case LGLSXP: if (0 <= ii && ii < nx && ii != NA_LOGICAL) LOGICAL(result)[i] = LOGICAL(x)[ii]; else LOGICAL(result)[i] = NA_LOGICAL; break; case INTSXP: if (0 <= ii && ii < nx && ii != NA_INTEGER) INTEGER(result)[i] = INTEGER(x)[ii]; else INTEGER(result)[i] = NA_INTEGER; break; case REALSXP: if (0 <= ii && ii < nx && ii != NA_INTEGER) REAL(result)[i] = REAL(x)[ii]; else REAL(result)[i] = NA_REAL; break; case CPLXSXP: if (0 <= ii && ii < nx && ii != NA_INTEGER) { COMPLEX(result)[i] = COMPLEX(x)[ii]; } else { COMPLEX(result)[i].r = NA_REAL; COMPLEX(result)[i].i = NA_REAL; } break; case STRSXP: if (0 <= ii && ii < nx && ii != NA_INTEGER) SET_STRING_ELT(result, i, STRING_ELT(x, ii)); else SET_STRING_ELT(result, i, NA_STRING); break; case VECSXP: case EXPRSXP: if (0 <= ii && ii < nx && ii != NA_INTEGER) SET_VECTOR_ELT(result, i, VECTOR_ELT(x, ii)); else SET_VECTOR_ELT(result, i, R_NilValue); break; case LISTSXP: /* cannot happen: pairlists are coerced to lists */ case LANGSXP: if (0 <= ii && ii < nx && ii != NA_INTEGER) { tmp2 = nthcdr(x, ii); SETCAR(tmp, CAR(tmp2)); SET_TAG(tmp, TAG(tmp2)); } else SETCAR(tmp, R_NilValue); tmp = CDR(tmp); break; case RAWSXP: if (0 <= ii && ii < nx && ii != NA_INTEGER) RAW(result)[i] = RAW(x)[ii]; else RAW(result)[i] = (Rbyte) 0; break; default: error("error in subset\n"); // errorcall(call, R_MSG_ob_nonsub, type2char(mode)); break; } } return result; } //}}}
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); }
void * convertToNative(void **val, SEXP r_val, ffi_type *type) /* need something about copying, to control memory recollection*/ { void *ans = NULL; if(type == &ffi_type_sexp) { SEXP *p = (SEXP *) R_alloc(sizeof(SEXP), 1); *p = r_val; ans = p; } else if(type == &ffi_type_pointer) { SEXPREC_ALIGN *p; if(r_val == R_NilValue) ans = NULL; else if(IS_S4_OBJECT(r_val) && R_is(r_val, "AddressOf")) { ans = getAddressOfExtPtr(GET_SLOT(r_val, Rf_install("ref"))); } else if(IS_S4_OBJECT(r_val) && R_is(r_val, "RNativeReference")) { ans = R_ExternalPtrAddr(GET_SLOT(r_val, Rf_install("ref"))); } else { /* Should be looking at the element type, not at r_val. */ switch(TYPEOF(r_val)) { case INTSXP: case LGLSXP: { p = ((SEXPREC_ALIGN *) r_val) + 1; ans = p; /* ans = &r_val + sizeof(SEXPREC_ALIGN*); */ /* INTEGER(r_val); */ } break; case REALSXP: p = ((SEXPREC_ALIGN *) r_val) + 1; ans = p; /* REAL(r_val); */ break; case STRSXP: /*XXX What should happen is not clear here. The char ** or the single */ ans = Rf_length(r_val) ? CHAR(STRING_ELT(r_val, 0)) : NULL; break; case EXTPTRSXP: ans = R_ExternalPtrAddr(r_val); break; case CLOSXP: ans = r_val; break; case RAWSXP: ans = RAW(r_val); break; default: PROBLEM "unhandled conversion from R type (%d) to native FFI type", TYPEOF(r_val) ERROR; break; } } } else { if(type->type == FFI_TYPE_STRUCT) { ans = convertRToStruct(r_val, type); } else if(type == &ffi_type_string) { const char * * tmp; tmp = (const char * * ) R_alloc(sizeof(char *), 1); if(r_val == R_NilValue) *tmp = NULL; else *tmp = CHAR(STRING_ELT(r_val, 0)); ans = tmp; } else if(type == &ffi_type_double) { ans = REAL(r_val); } else if(type == &ffi_type_float) { /* We allocate a float, populate it with the value and return a pointer to that new float. It is released when we return from the .Call(). */ float *tmp = (float *) R_alloc(sizeof(float), 1); *tmp = REAL(r_val)[0]; ans = tmp; } else if(type == &ffi_type_sint32) { #if 1 /*experiment*/ if(IS_S4_OBJECT(r_val) && R_is(r_val, "RNativeReference")) { void **tmp = (void **) malloc(sizeof(void *)); *tmp = R_ExternalPtrAddr(GET_SLOT(r_val, Rf_install("ref"))) ; return(tmp); } #endif if(TYPEOF(r_val) == INTSXP) { ans = INTEGER(r_val); } else if(IS_S4_OBJECT(r_val) && R_is(r_val, "RNativeReference")) { ans = (int *) R_ExternalPtrAddr(GET_SLOT(r_val, Rf_install("ref"))); } else { int *i = (int *) R_alloc(sizeof(int), 1); i[0] = INTEGER(coerceVector(r_val, INTSXP))[0]; ans = i; } } else if(type == &ffi_type_sint16) { short *s = (short *) R_alloc(1, 16); *s = INTEGER(coerceVector(r_val, INTSXP))[0]; ans = s; } else if(type == &ffi_type_uint32) { unsigned int *tmp = (unsigned int *) R_alloc(sizeof(unsigned int), 1); *tmp = TYPEOF(r_val) == REALSXP ? REAL(r_val)[0] : INTEGER(r_val)[0]; ans = tmp; } else if(type == &ffi_type_uint16) { unsigned short *tmp = (unsigned short *) R_alloc(sizeof(unsigned short), 1); *tmp = TYPEOF(r_val) == REALSXP ? REAL(r_val)[0] : INTEGER(r_val)[0]; ans = tmp; } } /* Rprintf("convert->native: %p\n", ans); */ return(ans); }
/* * 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; }
// 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; }
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; }
/** * 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 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 _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; }
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); }
void fft5(t_fft *x, int n1, int N1, int r, t_fft *t, int dir) { int i = r+n1; real *x0 = x[i]; i+=N1; real *x1 = x[i]; i+=N1; real *x2 = x[i]; i+=N1; real *x3 = x[i]; i+=N1; real *x4 = x[i]; real z00 = x1[0] + x4[0]; real z01 = x1[1] + x4[1]; real z10 = x2[0] + x3[0]; real z11 = x2[1] + x3[1]; real z20 = x1[0] - x4[0]; real z21 = x1[1] - x4[1]; real z30 = x2[0] - x3[0]; real z31 = x2[1] - x3[1]; real z40 = z00 + z10; real z41 = z01 + z11; real z50 = T510*(z00 - z10); real z51 = T510*(z01 - z11); real z60 = x0[0] - T511*z40; real z61 = x0[1] - T511*z41; real z70 = z50 + z60; real z71 = z51 + z61; real z80 = z60 - z50; real z81 = z61 - z51; real z90; real z91; if(dir==1) { z90 = -(T500*z20 + T501*z30); z91 = -(T500*z21 + T501*z31); } else { z90 = (T500*z20 + T501*z30); z91 = (T500*z21 + T501*z31); } real z100; real z101; if(dir==1) { z100 = (T500*z30 - T501*z20); z101 = (T500*z31 - T501*z21); } else { z100 = (T501*z20 - T500*z30); z101 = (T501*z21 - T500*z31); } x0[0] = x0[0] + z40; x0[1] = x0[1] + z41; real y10 = z70 - z91; real y11 = z71 + z90; real *t1 = t[n1]; real t10 = t1[0]; real t11 = t1[1]; x1[0] = REAL(t10,t11,y10,y11); x1[1] = IMAG(t10,t11,y10,y11); real y20 = z80 - z101; real y21 = z81 + z100; real *t2 = t[n1<<1]; real t20 = t2[0]; real t21 = t2[1]; x2[0] = REAL(t20,t21,y20,y21); x2[1] = IMAG(t20,t21,y20,y21); real y30 = z80 + z101; real y31 = z81 - z100; real *t3 = t[n1*3]; real t30 = t3[0]; real t31 = t3[1]; x3[0] = REAL(t30,t31,y30,y31); x3[1] = IMAG(t30,t31,y30,y31); real y40 = z70 + z91; real y41 = z71 - z90; real *t4 = t[n1<<2]; real t40 = t4[0]; real t41 = t4[1]; x4[0] = REAL(t40,t41,y40,y41); x4[1] = IMAG(t40,t41,y40,y41); }
/** get value of a field of an object or class object (int), return signature (string), field name (string) arrays and objects are returned as IDs (hence not evaluated) class name can be in either form / or . */ REPC SEXP RgetField(SEXP obj, SEXP sig, SEXP name, SEXP trueclass) { jobject o = 0; SEXP e; const char *retsig, *fnam; char *clnam = 0, *detsig = 0; jfieldID fid; jclass cls; int tc = asInteger(trueclass); JNIEnv *env=getJNIEnv(); if (obj == R_NilValue) return R_NilValue; if ( IS_JOBJREF(obj) ) obj = GET_SLOT(obj, install("jobj")); if (TYPEOF(obj)==EXTPTRSXP) { jverify(obj); o=(jobject)EXTPTR_PTR(obj); } else if (TYPEOF(obj)==STRSXP && LENGTH(obj)==1) clnam = strdup(CHAR(STRING_ELT(obj, 0))); else error("invalid object parameter"); if (!o && !clnam) error("cannot access a field of a NULL object"); #ifdef RJ_DEBUG if (o) { rjprintf("RgetField.object: "); printObject(env, o); } else { rjprintf("RgetField.class: %s\n", clnam); } #endif if (o) cls = objectClass(env, o); else { char *c = clnam; while(*c) { if (*c=='/') *c='.'; c++; } cls = findClass(env, clnam); free(clnam); if (!cls) { error("cannot find class %s", CHAR(STRING_ELT(obj, 0))); } } if (!cls) error("cannot determine object class"); #ifdef RJ_DEBUG rjprintf("RgetField.class: "); printObject(env, cls); #endif if (TYPEOF(name)!=STRSXP || LENGTH(name)!=1) { releaseObject(env, cls); error("invalid field name"); } fnam = CHAR(STRING_ELT(name,0)); if (sig == R_NilValue) { retsig = detsig = findFieldSignature(env, cls, fnam); if (!retsig) { releaseObject(env, cls); error("unable to detect signature for field '%s'", fnam); } } else { if (TYPEOF(sig)!=STRSXP || LENGTH(sig)!=1) { releaseObject(env, cls); error("invalid signature parameter"); } retsig = CHAR(STRING_ELT(sig,0)); } _dbg(rjprintf("field %s signature is %s\n",fnam,retsig)); if (o) { /* first try non-static fields */ fid = (*env)->GetFieldID(env, cls, fnam, retsig); checkExceptionsX(env, 1); if (!fid) { /* if that fails, try static ones */ o = 0; fid = (*env)->GetStaticFieldID(env, cls, fnam, retsig); } } else /* no choice if the object was a string */ fid = (*env)->GetStaticFieldID(env, cls, fnam, retsig); if (!fid) { checkExceptionsX(env, 1); releaseObject(env, cls); if (detsig) free(detsig); error("RgetField: field %s not found", fnam); } switch (*retsig) { case 'I': { int r=o? (*env)->GetIntField(env, o, fid): (*env)->GetStaticIntField(env, cls, fid); e = allocVector(INTSXP, 1); INTEGER(e)[0] = r; releaseObject(env, cls); if (detsig) free(detsig); return e; } case 'S': { jshort r=o? (*env)->GetShortField(env, o, fid): (*env)->GetStaticShortField(env, cls, fid); e = allocVector(INTSXP, 1); INTEGER(e)[0] = r; releaseObject(env, cls); if (detsig) free(detsig); return e; } case 'C': { int r=(int) (o? (*env)->GetCharField(env, o, fid): (*env)->GetStaticCharField(env, cls, fid)); e = allocVector(INTSXP, 1); INTEGER(e)[0] = r; releaseObject(env, cls); if (detsig) free(detsig); return e; } case 'B': { int r=(int) (o? (*env)->GetByteField(env, o, fid): (*env)->GetStaticByteField(env, cls, fid)); e = allocVector(INTSXP, 1); INTEGER(e)[0] = r; releaseObject(env, cls); if (detsig) free(detsig); return e; } case 'J': { jlong r=o? (*env)->GetLongField(env, o, fid): (*env)->GetStaticLongField(env, cls, fid); e = allocVector(REALSXP, 1); REAL(e)[0] = (double)r; releaseObject(env, cls); if (detsig) free(detsig); return e; } case 'Z': { jboolean r=o? (*env)->GetBooleanField(env, o, fid): (*env)->GetStaticBooleanField(env, cls, fid); e = allocVector(LGLSXP, 1); LOGICAL(e)[0] = r?1:0; releaseObject(env, cls); if (detsig) free(detsig); return e; } case 'D': { double r=o? (*env)->GetDoubleField(env, o, fid): (*env)->GetStaticDoubleField(env, cls, fid); e = allocVector(REALSXP, 1); REAL(e)[0] = r; releaseObject(env, cls); if (detsig) free(detsig); return e; } case 'F': { double r = (double) (o? (*env)->GetFloatField(env, o, fid): (*env)->GetStaticFloatField(env, cls, fid)); e = allocVector(REALSXP, 1); REAL(e)[0] = r; releaseObject(env, cls); if (detsig) free(detsig); return e; } case 'L': case '[': { SEXP rv; jobject r = o? (*env)->GetObjectField(env, o, fid): (*env)->GetStaticObjectField(env, cls, fid); _mp(MEM_PROF_OUT(" %08x LNEW field value\n", (int) r)) releaseObject(env, cls); if (tc) { if (detsig) free(detsig); return new_jobjRef(env, r, 0); } if (*retsig=='L') { /* need to fix the class name */ char *d = strdup(retsig), *c = d; while (*c) { if (*c==';') { *c=0; break; }; c++; } rv = new_jobjRef(env, r, d+1); free(d); } else rv = new_jobjRef(env, r, retsig); if (detsig) free(detsig); return rv; } } /* switch */ releaseObject(env, cls); if (detsig) { free(detsig); error("unknown field signature"); } error("unknown field signature '%s'", retsig); return R_NilValue; }
void fft7(t_fft *x, int n1, int N1, int r, t_fft *t, int dir) { int i = r+n1; real *x0 = x[i]; i+=N1; real *x1 = x[i]; i+=N1; real *x2 = x[i]; i+=N1; real *x3 = x[i]; i+=N1; real *x4 = x[i]; i+=N1; real *x5 = x[i]; i+=N1; real *x6 = x[i]; real u00 = x1[0] + x6[0]; real u01 = x1[1] + x6[1]; real u10 = x1[0] - x6[0]; real u11 = x1[1] - x6[1]; real u20 = x2[0] + x5[0]; real u21 = x2[1] + x5[1]; real u30 = x2[0] - x5[0]; real u31 = x2[1] - x5[1]; real u40 = x4[0] + x3[0]; real u41 = x4[1] + x3[1]; real u50 = x4[0] - x3[0]; real u51 = x4[1] - x3[1]; real u60 = u20 + u00; real u61 = u21 + u01; real u70 = u50 + u30; real u71 = u51 + u31; real b00 = x0[0] + u60 + u40; real b01 = x0[1] + u61 + u41; real b10 = C71*(u60 + u40); real b11 = C71*(u61 + u41); real b20 = C72*(u00 - u40); real b21 = C72*(u01 - u41); real b30 = C73*(u40 - u20); real b31 = C73*(u41 - u21); real b40 = C74*(u20 - u00); real b41 = C74*(u21 - u01); real b50; real b51; if(dir==1) { b50 = C75*(u70 + u10); b51 = C75*(u71 + u11); } else { b50 = -C75*(u70 + u10); b51 = -C75*(u71 + u11); } real b60; real b61; if(dir==1) { b60 = C76*(u10 - u50); b61 = C76*(u11 - u51); } else { b60 = C76*(u50 - u10); b61 = C76*(u51 - u11); } real b70; real b71; if(dir==1) { b70 = C77*(u50 - u30); b71 = C77*(u51 - u31); } else { b70 = C77*(u30 - u50); b71 = C77*(u31 - u51); } real b80; real b81; if(dir==1) { b80 = C78*(u30 - u10); b81 = C78*(u31 - u11); } else { b80 = C78*(u10 - u30); b81 = C78*(u11 - u31); } real T00 = b00 + b10; real T01 = b01 + b11; real T10 = b20 + b30; real T11 = b21 + b31; real T20 = b40 - b30; real T21 = b41 - b31; real T30 = -b20 - b40; real T31 = -b21 - b41; real T40 = b60 + b70; real T41 = b61 + b71; real T50 = b80 - b70; real T51 = b81 - b71; real T60 = -b80 - b60; real T61 = -b81 - b61; real T70 = T00 + T10; real T71 = T01 + T11; real T80 = T00 + T20; real T81 = T01 + T21; real T90 = T00 + T30; real T91 = T01 + T31; real T100 = T40 + b50; real T101 = T41 + b51; real T110 = T50 + b50; real T111 = T51 + b51; real T120 = T60 + b50; real T121 = T61 + b51; x0[0] = b00; x0[1] = b01; real y10 = T70 + T101; real y11 = T71 - T100; real *t1 = t[n1]; real t10 = t1[0]; real t11 = t1[1]; x1[0] = REAL(t10,t11,y10,y11); x1[1] = IMAG(t10,t11,y10,y11); real y20 = T90 + T121; real y21 = T91 - T120; real *t2 = t[n1<<1]; real t20 = t2[0]; real t21 = t2[1]; x2[0] = REAL(t20,t21,y20,y21); x2[1] = IMAG(t20,t21,y20,y21); real y30 = T80 - T111; real y31 = T81 + T110; real *t3 = t[n1*3]; real t30 = t3[0]; real t31 = t3[1]; x3[0] = REAL(t30,t31,y30,y31); x3[1] = IMAG(t30,t31,y30,y31); real y40 = T80 + T111; real y41 = T81 - T110; real *t4 = t[n1<<2]; real t40 = t4[0]; real t41 = t4[1]; x4[0] = REAL(t40,t41,y40,y41); x4[1] = IMAG(t40,t41,y40,y41); real y50 = T90 - T121; real y51 = T91 + T120; real *t5 = t[n1*5]; real t50 = t5[0]; real t51 = t5[1]; x5[0] = REAL(t50,t51,y50,y51); x5[1] = IMAG(t50,t51,y50,y51); real y60 = T70 - T101; real y61 = T71 + T100; real *t6 = t[n1*6]; real t60 = t6[0]; real t61 = t6[1]; x6[0] = REAL(t60,t61,y60,y61); x6[1] = IMAG(t60,t61,y60,y61); }
SEXP declust(SEXP theta, SEXP rbwd, SEXP revents, SEXP rpoly, SEXP tperiod) { SEXP dim, pdim, out, integ0; // extract events PROTECT(dim = allocVector(INTSXP, 2)); dim = getAttrib(revents, R_DimSymbol); int N = INTEGER(dim)[0]; double *events = REAL(revents); double t[N], x[N], y[N], m[N], bk[N], pb[N], lam[N]; for (int i = 0; i < N; i++) { t[i] = events[i]; x[i] = events[N + i]; y[i] = events[2 * N + i]; m[i] = events[3 * N + i]; bk[i] = events[5 * N + i]; pb[i] = events[6 * N + i]; lam[i] = events[7 * N + i]; } // extract polygon information PROTECT(pdim = allocVector(INTSXP, 2)); pdim = getAttrib(rpoly, R_DimSymbol); int np = INTEGER(pdim)[0]; double *poly = REAL(rpoly); double px[np], py[np]; for (int i = 0; i < np; i++) { px[i] = poly[i]; py[i] = poly[np + i]; } // extract time period information double *tper = REAL(tperiod); double tstart2 = tper[0], tlength = tper[1]; // extract bandwidthes double *bwd = REAL(rbwd); // extract model paramters double *tht = REAL(theta); double s, r0, w[1]; for (int i = 0; i < N; i++) { s = 0; for (int j = 0; j < N; j++) { r0 = dist(x[i], y[i], x[j], y[j]); s += pb[j] * dGauss(r0, bwd[j]); } bk[i] = s / (tlength - tstart2); events[5 * N + i] = bk[i]; } s = 0; for (int i = 0; i < N; i++) { w[0] = bwd[i]; s += pb[i] * polyinteg(pGauss, w, &np, px, py, x[i], y[i]); lam[i] = lambdaj(tht,i, t, x, y, m, bk); events[6 * N + i] = (tht[0] * tht[0] * bk[i]) / lam[i]; events[7 * N + i] = lam[i]; } PROTECT(out = allocVector(VECSXP, 2)); PROTECT(integ0 = allocVector(REALSXP, 1)); double *integ0P = REAL(integ0); integ0P[0] = s; SET_VECTOR_ELT(out, 0, revents); SET_VECTOR_ELT(out, 1, integ0); UNPROTECT(4); return(out); }