void do_matrixApply(SEXP ans, SEXP data, SEXP margin, SEXP function, int my_start, int my_end, int *dimensions, int worldRank) { SEXP data_chunk, R_fcall, parsedCmd = R_NilValue; int i, j; double *rdata, *rchunk; rdata = REAL(data); PROTECT(parsedCmd = parseExpression(function)); /* Create R LANGSXP Vector, R function holder length of the vector is 1 + number of arguments */ PROTECT(R_fcall = lang2(VECTOR_ELT(parsedCmd, 0), R_NilValue)); if (INTEGER(margin)[0] == 1) { PROTECT(data_chunk = allocVector(REALSXP, dimensions[1])); rchunk = REAL(data_chunk); for(i=0; i<my_end-my_start; i++) { /* Master process won't have data aligned in memory in this case */ if (worldRank != MASTER_PROCESS) { for(j=0; j<dimensions[1]; j++) { rchunk[j] = rdata[i*dimensions[1]+j]; } } else { for(j=0; j<dimensions[1]; j++) { rchunk[j] = rdata[j*dimensions[0]+i]; } } SETCADR(R_fcall, data_chunk); SET_VECTOR_ELT(ans, i, eval(R_fcall, R_GlobalEnv)); } } else if (INTEGER(margin)[0] == 2) { PROTECT(data_chunk = allocVector(REALSXP, dimensions[0])); rchunk = REAL(data_chunk); for(i=0; i<my_end-my_start; i++) { for(j=0; j<dimensions[0]; j++) { rchunk[j] = rdata[j+i*dimensions[0]]; } SETCADR(R_fcall, data_chunk); SET_VECTOR_ELT(ans, i, eval(R_fcall, R_GlobalEnv)); } } UNPROTECT(3); return; }
// [[register]] SEXP unmelt(SEXP data, SEXP uniq_id, SEXP other_ind_, SEXP id_ind_, SEXP value_ind_) { // int id_ind = asInteger(id_ind_); int value_ind = asInteger(value_ind_); int* other_ind = INTEGER(other_ind_); int nRow = (int)(length(VECTOR_ELT(data, 0)) / length(uniq_id)); int numprotect = 0; if (TYPEOF(uniq_id) != STRSXP) { GUARD(uniq_id = coerceVector(uniq_id, STRSXP)); } int n_uniq = length(uniq_id); SEXP output; GUARD(output = allocVector(VECSXP, length(other_ind_) + length(uniq_id))); int n_other = length(other_ind_); // ensure that the unmelting process will go smoothly #define HANDLE_CASE(RTYPE, CTYPE, ACCESSOR) \ case RTYPE: { \ CTYPE* tmp = ACCESSOR( VECTOR_ELT(data, other_ind[i]) ); \ for (int j=0; j < nRow; ++j) { \ for (int k=1; k < n_uniq; ++k) { \ if (tmp[j] != tmp[j + nRow*k]) { \ Rf_error("Mismatch in elements at indices %i and %i in vector %s", j+1, j + nRow*k+1, CHAR(STRING_ELT(getAttrib(data, R_NamesSymbol), other_ind[i]))); \ } \ } \ } \ break; \ } \ if (n_uniq > 1) { for (int i=0; i < n_other; ++i) { switch (TYPEOF(VECTOR_ELT(data, other_ind[i]))) { HANDLE_CASE(LGLSXP, int, LOGICAL); HANDLE_CASE(INTSXP, int, INTEGER); HANDLE_CASE(REALSXP, double, REAL); HANDLE_CASE(STRSXP, SEXP, STRING_PTR); default: Rf_error("Unhandled type %s", type2char(TYPEOF(VECTOR_ELT(data, other_ind[i])))); } } } #undef HANDLE_CASE // copy in the 'other' variables first #define COPY(RTYPE, CTYPE, ACCESSOR) { \ PROTECT(tmp = allocVector(RTYPE, nRow)); \ CTYPE* tmp_ptr = ACCESSOR(tmp); \ CTYPE* data_ptr = ACCESSOR(VECTOR_ELT(data, other_ind[i])); \ for (int i=0; i < nRow; ++i) { \ tmp_ptr[i] = data_ptr[i]; \ } \ SET_VECTOR_ELT(output, i, tmp); \ UNPROTECT(1); \ break; \ } \ SEXP tmp; for (int i=0; i < n_other; ++i) { switch (TYPEOF(VECTOR_ELT(data, other_ind[i]))) { case LGLSXP: COPY(LGLSXP, int, LOGICAL); case INTSXP: COPY(INTSXP, int, INTEGER); case REALSXP: COPY(REALSXP, double, REAL); case STRSXP: COPY(STRSXP, SEXP, STRING_PTR); default: Rf_error("Unhandled SEXP type"); } } #undef COPY #define COPY(RTYPE, CTYPE, ACCESSOR) { \ PROTECT(tmp = allocVector(RTYPE, nRow)); \ CTYPE* tmp_ptr = ACCESSOR(tmp); \ CTYPE* data_ptr = ACCESSOR(VECTOR_ELT(data, value_ind)); \ for (int j=0; j < nRow; ++j) { \ tmp_ptr[j] = data_ptr[j + (i*nRow)]; \ } \ SET_VECTOR_ELT(output, i + n_other, tmp); \ UNPROTECT(1); \ break; \ } \ // copy the value int valuetype = TYPEOF(VECTOR_ELT(data, value_ind)); for (int i=0; i < n_uniq; ++i) { switch (valuetype) { case LGLSXP: COPY(LGLSXP, int, LOGICAL); case INTSXP: COPY(INTSXP, int, INTEGER); case REALSXP: COPY(REALSXP, double, REAL); case STRSXP: COPY(STRSXP, SEXP, STRING_PTR); } } // set the names SEXP datanames = getAttrib(data, R_NamesSymbol); SEXP names; GUARD(names = allocVector(STRSXP, n_other + n_uniq)); for (int i=0; i < n_other; ++i) { SET_STRING_ELT(names, i, STRING_ELT(datanames, i)); } for (int i=0; i < n_uniq; ++i) { SET_STRING_ELT(names, n_other+i, STRING_ELT(uniq_id, i)); } setAttrib(output, R_NamesSymbol, names); // set the class setAttrib(output, R_ClassSymbol, mkString("data.frame")); // set the rows SEXP rownames; GUARD( rownames=allocVector(INTSXP, nRow) ); int* rownames_ptr = INTEGER(rownames); for (int i=0; i < nRow; ++i) { rownames_ptr[i] = i+1; } setAttrib(output, R_RowNamesSymbol, rownames); UNGUARD; return output; }
/** 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; }
Sampler * sampler_new (SEXP opts) { Sampler *ss; SEXP SEXPTmp; ss = (Sampler *) R_alloc(1, sizeof(struct Sampler)); ss->nStreams = INTEGER(getListElement(opts, "nStreams"))[0]; ss->nPeriods = INTEGER(getListElement(opts, "nPeriods"))[0]; ss->nStreamsPreResamp = INTEGER(getListElement(opts, "nStreamsPreResamp"))[0]; ss->dimPerPeriod = INTEGER(getListElement(opts, "dimPerPeriod"))[0]; ss->dimSummPerPeriod = INTEGER(getListElement(opts, "dimSummPerPeriod"))[0]; ss->returnStreams = LOGICAL(getListElement(opts, "returnStreams"))[0]; ss->returnLogWeights = LOGICAL(getListElement(opts, "returnLogWeights"))[0]; ss->nMHSteps = INTEGER(getListElement(opts, "nMHSteps"))[0]; ss->verboseLevel = INTEGER(getListElement(opts, "verboseLevel"))[0]; ss->printEstTimeAt = 10; ss->printEstTimeNTimes = 10; /* FIXME: The setting for ss->printDotAt, is it all right? */ ss->printInitialDotsWhen = ss->printEstTimeAt / 10; ss->printDotAt = 0; ss->nDotsPerLine = 20; ss->eachDotWorth = (int) ceil((ss->nPeriods - ss->printEstTimeAt + 1.0) / \ (ss->printEstTimeNTimes * ss->nDotsPerLine)); ss->nProtected = 0; /* The user provided functions */ ss->propagateFunc = getListElement(opts, "propagateFunc"); ss->propagateArgsList = (ArgsList1 *) R_alloc(1, sizeof(struct ArgsList1)); ss->nProtected += args_list1_init(ss->propagateArgsList); ss->resampCriterionFunc = getListElement(opts, "resampCriterionFunc"); ss->resampCriterionArgsList = (ArgsList2 *) R_alloc(1, sizeof(struct ArgsList2)); ss->nProtected += args_list2_init(ss->resampCriterionArgsList); ss->resampFunc = getListElement(opts, "resampFunc"); ss->resampArgsList = (ArgsList2 *) R_alloc(1, sizeof(struct ArgsList2)); ss->nProtected += args_list2_init(ss->resampArgsList); ss->summaryFunc = getListElement(opts, "summaryFunc"); ss->summaryArgsList = (ArgsList2 *) R_alloc(1, sizeof(struct ArgsList2)); ss->nProtected += args_list2_init(ss->summaryArgsList); ss->MHUpdateFunc = getListElement(opts, "MHUpdateFunc"); ss->MHUpdateArgsList = (ArgsList3 *) R_alloc(1, sizeof(struct ArgsList3)); ss->nProtected += args_list3_init(ss->MHUpdateArgsList); SEXPTmp = getListElement(opts, "doCallFunc"); PROTECT(ss->doCallFuncCall = lang4(SEXPTmp, R_NilValue, R_NilValue, R_NilValue)); ++(ss->nProtected); ss->doCallFuncEnv = getListElement(opts, "doCallFuncEnv"); SEXPTmp = getListElement(opts, "procTimeFunc"); PROTECT(ss->procTimeFuncCall = lang1(SEXPTmp)); ++(ss->nProtected); ss->procTimeFuncEnv = getListElement(opts, "procTimeFuncEnv"); ss->timeDetails = (TimeDetails *) R_alloc(1, sizeof(struct TimeDetails)); PROTECT(ss->SEXPCurrentPeriod = allocVector(INTSXP, 1)); ++(ss->nProtected); PROTECT(ss->SEXPNStreamsToGenerate = allocVector(INTSXP, 1)); ++(ss->nProtected); PROTECT(ss->SEXPNMHSteps = allocVector(INTSXP, 1)); ++(ss->nProtected); ss->dotsList = getListElement(opts, "dotsList"); ss->SEXPCurrentStreams = R_NilValue; PROTECT(ss->SEXPLag1Streams = allocMatrix(REALSXP, ss->nStreams, ss->dimPerPeriod)); ++(ss->nProtected); ss->SEXPCurrentLogWeights = R_NilValue; PROTECT(ss->SEXPCurrentAdjWeights = allocVector(REALSXP, ss->nStreamsPreResamp)); ++(ss->nProtected); PROTECT(ss->SEXPLag1LogWeights = allocVector(REALSXP, ss->nStreams)); ++(ss->nProtected); PROTECT(ss->SEXPLag1AdjWeights = allocVector(REALSXP, ss->nStreams)); ++(ss->nProtected); PROTECT(ss->SEXPAcceptanceRates = allocVector(REALSXP, ss->nStreams)); ++(ss->nProtected); PROTECT(ss->SEXPSummary = allocVector(REALSXP, ss->dimSummPerPeriod)); ++(ss->nProtected); PROTECT(ss->SEXPPropUniqueStreamIds = allocVector(REALSXP, 1)); ++(ss->nProtected); ss->scratch_RC = (ResampleContext *) R_alloc(1, sizeof(struct ResampleContext)); ss->scratch_RC->streamIds = (int *) R_alloc(ss->nStreams, sizeof(int)); ss->scratch_RC->uniqueStreamIds = (int *) R_alloc(ss->nStreams, sizeof(int)); ss->scratch_RC->partialSum = (double *) R_alloc(ss->nStreamsPreResamp, sizeof(double)); return ss; }
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; }
b = twiddle(ulv, thisi, 1) == twiddle(ulv, previ, 1); } break; // TO DO: store previ twiddle call, but it'll need to be vector since this is in a loop through columns. Hopefully the first == will short circuit most often default : error("Type '%s' not supported", type2char(TYPEOF(v))); } } if (!b) iidx[len++] = i+1; if (len >= isize) { isize = 1.1*isize*nrow/i; n_iidx = Realloc(iidx, isize, int); if (n_iidx != NULL) iidx = n_iidx; else error("Error in reallocating memory in 'uniqlist'\n"); } } PROTECT(ans = allocVector(INTSXP, len)); memcpy(INTEGER(ans), iidx, sizeof(int)*len); // sizeof is of type size_t - no integer overflow issues Free(iidx); UNPROTECT(1); return(ans); } SEXP uniqlengths(SEXP x, SEXP n) { SEXP ans; R_len_t i, len; if (TYPEOF(x) != INTSXP || length(x) < 0) error("Input argument 'x' to 'uniqlengths' must be an integer vector of length >= 0"); if (TYPEOF(n) != INTSXP || length(n) != 1) error("Input argument 'n' to 'uniqlengths' must be an integer vector of length 1"); PROTECT(ans = allocVector(INTSXP, length(x))); len = length(x); for (i=1; i<len; i++) { INTEGER(ans)[i-1] = INTEGER(x)[i] - INTEGER(x)[i-1];
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); }
/* Note that NA_STRING is not handled separately here. This is deliberate -- see ?paste -- and implicitly coerces it to "NA" */ SEXP attribute_hidden do_paste(SEXP call, SEXP op, SEXP args, SEXP env) { SEXP ans, collapse, sep, x; int sepw, u_sepw, ienc; R_xlen_t i, j, k, maxlen, nx, pwidth; const char *s, *cbuf, *csep=NULL, *u_csep=NULL; char *buf; Rboolean allKnown, anyKnown, use_UTF8, use_Bytes, sepASCII = TRUE, sepUTF8 = FALSE, sepBytes = FALSE, sepKnown = FALSE, use_sep = (PRIMVAL(op) == 0); const void *vmax; checkArity(op, args); /* We use formatting and so we must initialize printing. */ PrintDefaults(); /* Check the arguments */ x = CAR(args); if (!isVectorList(x)) error(_("invalid first argument")); nx = xlength(x); if(use_sep) { /* paste(..., sep, .) */ sep = CADR(args); if (!isString(sep) || LENGTH(sep) <= 0 || STRING_ELT(sep, 0) == NA_STRING) error(_("invalid separator")); sep = STRING_ELT(sep, 0); csep = translateChar(sep); u_sepw = sepw = (int) strlen(csep); // will be short sepASCII = strIsASCII(csep); sepKnown = ENC_KNOWN(sep) > 0; sepUTF8 = IS_UTF8(sep); sepBytes = IS_BYTES(sep); collapse = CADDR(args); } else { /* paste0(..., .) */ u_sepw = sepw = 0; sep = R_NilValue;/* -Wall */ collapse = CADR(args); } if (!isNull(collapse)) if(!isString(collapse) || LENGTH(collapse) <= 0 || STRING_ELT(collapse, 0) == NA_STRING) error(_("invalid '%s' argument"), "collapse"); if(nx == 0) return (!isNull(collapse)) ? mkString("") : allocVector(STRSXP, 0); /* Maximum argument length, coerce if needed */ maxlen = 0; for (j = 0; j < nx; j++) { if (!isString(VECTOR_ELT(x, j))) { /* formerly in R code: moved to C for speed */ SEXP call, xj = VECTOR_ELT(x, j); if(OBJECT(xj)) { /* method dispatch */ PROTECT(call = lang2(install("as.character"), xj)); SET_VECTOR_ELT(x, j, eval(call, env)); UNPROTECT(1); } else if (isSymbol(xj)) SET_VECTOR_ELT(x, j, ScalarString(PRINTNAME(xj))); else SET_VECTOR_ELT(x, j, coerceVector(xj, STRSXP)); if (!isString(VECTOR_ELT(x, j))) error(_("non-string argument to internal 'paste'")); } if(xlength(VECTOR_ELT(x, j)) > maxlen) maxlen = xlength(VECTOR_ELT(x, j)); } if(maxlen == 0) return (!isNull(collapse)) ? mkString("") : allocVector(STRSXP, 0); PROTECT(ans = allocVector(STRSXP, maxlen)); for (i = 0; i < maxlen; i++) { /* Strategy for marking the encoding: if all inputs (including * the separator) are ASCII, so is the output and we don't * need to mark. Otherwise if all non-ASCII inputs are of * declared encoding, we should mark. * Need to be careful only to include separator if it is used. */ anyKnown = FALSE; allKnown = TRUE; use_UTF8 = FALSE; use_Bytes = FALSE; if(nx > 1) { allKnown = sepKnown || sepASCII; anyKnown = sepKnown; use_UTF8 = sepUTF8; use_Bytes = sepBytes; } pwidth = 0; for (j = 0; j < nx; j++) { k = xlength(VECTOR_ELT(x, j)); if (k > 0) { SEXP cs = STRING_ELT(VECTOR_ELT(x, j), i % k); if(IS_UTF8(cs)) use_UTF8 = TRUE; if(IS_BYTES(cs)) use_Bytes = TRUE; } } if (use_Bytes) use_UTF8 = FALSE; vmax = vmaxget(); for (j = 0; j < nx; j++) { k = xlength(VECTOR_ELT(x, j)); if (k > 0) { if(use_Bytes) pwidth += strlen(CHAR(STRING_ELT(VECTOR_ELT(x, j), i % k))); else if(use_UTF8) pwidth += strlen(translateCharUTF8(STRING_ELT(VECTOR_ELT(x, j), i % k))); else pwidth += strlen(translateChar(STRING_ELT(VECTOR_ELT(x, j), i % k))); vmaxset(vmax); } } if(use_sep) { if (use_UTF8 && !u_csep) { u_csep = translateCharUTF8(sep); u_sepw = (int) strlen(u_csep); // will be short } pwidth += (nx - 1) * (use_UTF8 ? u_sepw : sepw); } if (pwidth > INT_MAX) error(_("result would exceed 2^31-1 bytes")); cbuf = buf = R_AllocStringBuffer(pwidth, &cbuff); vmax = vmaxget(); for (j = 0; j < nx; j++) { k = xlength(VECTOR_ELT(x, j)); if (k > 0) { SEXP cs = STRING_ELT(VECTOR_ELT(x, j), i % k); if (use_UTF8) { s = translateCharUTF8(cs); strcpy(buf, s); buf += strlen(s); } else { s = use_Bytes ? CHAR(cs) : translateChar(cs); strcpy(buf, s); buf += strlen(s); allKnown = allKnown && (strIsASCII(s) || (ENC_KNOWN(cs)> 0)); anyKnown = anyKnown || (ENC_KNOWN(cs)> 0); } } if (sepw != 0 && j != nx - 1) { if (use_UTF8) { strcpy(buf, u_csep); buf += u_sepw; } else { strcpy(buf, csep); buf += sepw; } } vmax = vmaxget(); } ienc = 0; if(use_UTF8) ienc = CE_UTF8; else if(use_Bytes) ienc = CE_BYTES; else if(anyKnown && allKnown) { if(known_to_be_latin1) ienc = CE_LATIN1; if(known_to_be_utf8) ienc = CE_UTF8; } SET_STRING_ELT(ans, i, mkCharCE(cbuf, ienc)); } /* Now collapse, if required. */ if(collapse != R_NilValue && (nx = XLENGTH(ans)) > 0) { sep = STRING_ELT(collapse, 0); use_UTF8 = IS_UTF8(sep); use_Bytes = IS_BYTES(sep); for (i = 0; i < nx; i++) { if(IS_UTF8(STRING_ELT(ans, i))) use_UTF8 = TRUE; if(IS_BYTES(STRING_ELT(ans, i))) use_Bytes = TRUE; } if(use_Bytes) { csep = CHAR(sep); use_UTF8 = FALSE; } else if(use_UTF8) csep = translateCharUTF8(sep); else csep = translateChar(sep); sepw = (int) strlen(csep); anyKnown = ENC_KNOWN(sep) > 0; allKnown = anyKnown || strIsASCII(csep); pwidth = 0; vmax = vmaxget(); for (i = 0; i < nx; i++) if(use_UTF8) { pwidth += strlen(translateCharUTF8(STRING_ELT(ans, i))); vmaxset(vmax); } else /* already translated */ pwidth += strlen(CHAR(STRING_ELT(ans, i))); pwidth += (nx - 1) * sepw; if (pwidth > INT_MAX) error(_("result would exceed 2^31-1 bytes")); cbuf = buf = R_AllocStringBuffer(pwidth, &cbuff); vmax = vmaxget(); for (i = 0; i < nx; i++) { if(i > 0) { strcpy(buf, csep); buf += sepw; } if(use_UTF8) s = translateCharUTF8(STRING_ELT(ans, i)); else /* already translated */ s = CHAR(STRING_ELT(ans, i)); strcpy(buf, s); while (*buf) buf++; allKnown = allKnown && (strIsASCII(s) || (ENC_KNOWN(STRING_ELT(ans, i)) > 0)); anyKnown = anyKnown || (ENC_KNOWN(STRING_ELT(ans, i)) > 0); if(use_UTF8) vmaxset(vmax); } UNPROTECT(1); ienc = CE_NATIVE; if(use_UTF8) ienc = CE_UTF8; else if(use_Bytes) ienc = CE_BYTES; else if(anyKnown && allKnown) { if(known_to_be_latin1) ienc = CE_LATIN1; if(known_to_be_utf8) ienc = CE_UTF8; } PROTECT(ans = allocVector(STRSXP, 1)); SET_STRING_ELT(ans, 0, mkCharCE(cbuf, ienc)); } R_FreeStringBufferL(&cbuff); UNPROTECT(1); return ans; }
SEXP attribute_hidden do_formatinfo(SEXP call, SEXP op, SEXP args, SEXP env) { SEXP x; int digits, nsmall, no = 1, w, d, e, wi, di, ei; checkArity(op, args); x = CAR(args); R_xlen_t n = XLENGTH(x); PrintDefaults(); digits = asInteger(CADR(args)); if (!isNull(CADR(args))) { digits = asInteger(CADR(args)); if (digits == NA_INTEGER || digits < R_MIN_DIGITS_OPT || digits > R_MAX_DIGITS_OPT) error(_("invalid '%s' argument"), "digits"); R_print.digits = digits; } nsmall = asInteger(CADDR(args)); if (nsmall == NA_INTEGER || nsmall < 0 || nsmall > 20) error(_("invalid '%s' argument"), "nsmall"); w = 0; d = 0; e = 0; switch (TYPEOF(x)) { case RAWSXP: formatRaw(RAW(x), n, &w); break; case LGLSXP: formatLogical(LOGICAL(x), n, &w); break; case INTSXP: formatInteger(INTEGER(x), n, &w); break; case REALSXP: no = 3; formatReal(REAL(x), n, &w, &d, &e, nsmall); break; case CPLXSXP: no = 6; wi = di = ei = 0; formatComplex(COMPLEX(x), n, &w, &d, &e, &wi, &di, &ei, nsmall); break; case STRSXP: for (R_xlen_t i = 0; i < n; i++) if (STRING_ELT(x, i) != NA_STRING) { int il = Rstrlen(STRING_ELT(x, i), 0); if (il > w) w = il; } break; default: error(_("atomic vector arguments only")); } x = allocVector(INTSXP, no); INTEGER(x)[0] = w; if(no > 1) { INTEGER(x)[1] = d; INTEGER(x)[2] = e; } if(no > 3) { INTEGER(x)[3] = wi; INTEGER(x)[4] = di; INTEGER(x)[5] = ei; } return x; }
SEXP attribute_hidden do_filepath(SEXP call, SEXP op, SEXP args, SEXP env) { SEXP ans, sep, x; int i, j, k, ln, maxlen, nx, nzero, pwidth, sepw; const char *s, *csep, *cbuf; char *buf; checkArity(op, args); /* Check the arguments */ x = CAR(args); if (!isVectorList(x)) error(_("invalid first argument")); nx = length(x); if(nx == 0) return allocVector(STRSXP, 0); sep = CADR(args); if (!isString(sep) || LENGTH(sep) <= 0 || STRING_ELT(sep, 0) == NA_STRING) error(_("invalid separator")); sep = STRING_ELT(sep, 0); csep = CHAR(sep); sepw = (int) strlen(csep); /* hopefully 1 */ /* Any zero-length argument gives zero-length result */ maxlen = 0; nzero = 0; for (j = 0; j < nx; j++) { if (!isString(VECTOR_ELT(x, j))) { /* formerly in R code: moved to C for speed */ SEXP call, xj = VECTOR_ELT(x, j); if(OBJECT(xj)) { /* method dispatch */ PROTECT(call = lang2(install("as.character"), xj)); SET_VECTOR_ELT(x, j, eval(call, env)); UNPROTECT(1); } else if (isSymbol(xj)) SET_VECTOR_ELT(x, j, ScalarString(PRINTNAME(xj))); else SET_VECTOR_ELT(x, j, coerceVector(xj, STRSXP)); if (!isString(VECTOR_ELT(x, j))) error(_("non-string argument to Internal paste")); } ln = length(VECTOR_ELT(x, j)); if(ln > maxlen) maxlen = ln; if(ln == 0) {nzero++; break;} } if(nzero || maxlen == 0) return allocVector(STRSXP, 0); PROTECT(ans = allocVector(STRSXP, maxlen)); for (i = 0; i < maxlen; i++) { pwidth = 0; for (j = 0; j < nx; j++) { k = length(VECTOR_ELT(x, j)); pwidth += (int) strlen(translateChar(STRING_ELT(VECTOR_ELT(x, j), i % k))); } pwidth += (nx - 1) * sepw; cbuf = buf = R_AllocStringBuffer(pwidth, &cbuff); for (j = 0; j < nx; j++) { k = length(VECTOR_ELT(x, j)); if (k > 0) { s = translateChar(STRING_ELT(VECTOR_ELT(x, j), i % k)); strcpy(buf, s); buf += strlen(s); } if (j != nx - 1 && sepw != 0) { strcpy(buf, csep); buf += sepw; } } #ifdef Win32 // Trailing seps are invalid for file paths except for / and d:/ if(streql(csep, "/") || streql(csep, "\\")) { if(buf > cbuf) { buf--; if(*buf == csep[0] && buf > cbuf && (buf != cbuf+2 || cbuf[1] != ':')) *buf = '\0'; } } #endif SET_STRING_ELT(ans, i, mkChar(cbuf)); } R_FreeStringBufferL(&cbuff); UNPROTECT(1); return ans; }
/* format.default(x, trim, digits, nsmall, width, justify, na.encode, scientific) */ SEXP attribute_hidden do_format(SEXP call, SEXP op, SEXP args, SEXP env) { SEXP l, x, y, swd; int il, digits, trim = 0, nsmall = 0, wd = 0, adj = -1, na, sci = 0; int w, d, e; int wi, di, ei, scikeep; const char *strp; R_xlen_t i, n; checkArity(op, args); PrintDefaults(); scikeep = R_print.scipen; if (isEnvironment(x = CAR(args))) { return mkString(EncodeEnvironment(x)); } else if (!isVector(x)) error(_("first argument must be atomic")); args = CDR(args); trim = asLogical(CAR(args)); if (trim == NA_INTEGER) error(_("invalid '%s' argument"), "trim"); args = CDR(args); if (!isNull(CAR(args))) { digits = asInteger(CAR(args)); if (digits == NA_INTEGER || digits < R_MIN_DIGITS_OPT || digits > R_MAX_DIGITS_OPT) error(_("invalid '%s' argument"), "digits"); R_print.digits = digits; } args = CDR(args); nsmall = asInteger(CAR(args)); if (nsmall == NA_INTEGER || nsmall < 0 || nsmall > 20) error(_("invalid '%s' argument"), "nsmall"); args = CDR(args); if (isNull(swd = CAR(args))) wd = 0; else wd = asInteger(swd); if(wd == NA_INTEGER) error(_("invalid '%s' argument"), "width"); args = CDR(args); adj = asInteger(CAR(args)); if(adj == NA_INTEGER || adj < 0 || adj > 3) error(_("invalid '%s' argument"), "justify"); args = CDR(args); na = asLogical(CAR(args)); if(na == NA_LOGICAL) error(_("invalid '%s' argument"), "na.encode"); args = CDR(args); if(LENGTH(CAR(args)) != 1) error(_("invalid '%s' argument"), "scientific"); if(isLogical(CAR(args))) { int tmp = LOGICAL(CAR(args))[0]; if(tmp == NA_LOGICAL) sci = NA_INTEGER; else sci = tmp > 0 ?-100 : 100; } else if (isNumeric(CAR(args))) { sci = asInteger(CAR(args)); } else error(_("invalid '%s' argument"), "scientific"); if(sci != NA_INTEGER) R_print.scipen = sci; if ((n = XLENGTH(x)) <= 0) { PROTECT(y = allocVector(STRSXP, 0)); } else { switch (TYPEOF(x)) { case LGLSXP: PROTECT(y = allocVector(STRSXP, n)); if (trim) w = 0; else formatLogical(LOGICAL(x), n, &w); w = imax2(w, wd); for (i = 0; i < n; i++) { strp = EncodeLogical(LOGICAL(x)[i], w); SET_STRING_ELT(y, i, mkChar(strp)); } break; case INTSXP: PROTECT(y = allocVector(STRSXP, n)); if (trim) w = 0; else formatInteger(INTEGER(x), n, &w); w = imax2(w, wd); for (i = 0; i < n; i++) { strp = EncodeInteger(INTEGER(x)[i], w); SET_STRING_ELT(y, i, mkChar(strp)); } break; case REALSXP: formatReal(REAL(x), n, &w, &d, &e, nsmall); if (trim) w = 0; w = imax2(w, wd); PROTECT(y = allocVector(STRSXP, n)); for (i = 0; i < n; i++) { strp = EncodeReal0(REAL(x)[i], w, d, e, OutDec); SET_STRING_ELT(y, i, mkChar(strp)); } break; case CPLXSXP: formatComplex(COMPLEX(x), n, &w, &d, &e, &wi, &di, &ei, nsmall); if (trim) wi = w = 0; w = imax2(w, wd); wi = imax2(wi, wd); PROTECT(y = allocVector(STRSXP, n)); for (i = 0; i < n; i++) { strp = EncodeComplex(COMPLEX(x)[i], w, d, e, wi, di, ei, OutDec); SET_STRING_ELT(y, i, mkChar(strp)); } break; case STRSXP: { /* this has to be different from formatString/EncodeString as we don't actually want to encode here */ const char *s; char *q; int b, b0, cnt = 0, j; SEXP s0, xx; /* This is clumsy, but it saves rewriting and re-testing this complex code */ PROTECT(xx = duplicate(x)); for (i = 0; i < n; i++) { SEXP tmp = STRING_ELT(xx, i); if(IS_BYTES(tmp)) { const char *p = CHAR(tmp), *q; char *pp = R_alloc(4*strlen(p)+1, 1), *qq = pp, buf[5]; for (q = p; *q; q++) { unsigned char k = (unsigned char) *q; if (k >= 0x20 && k < 0x80) { *qq++ = *q; } else { snprintf(buf, 5, "\\x%02x", k); for(int j = 0; j < 4; j++) *qq++ = buf[j]; } } *qq = '\0'; s = pp; } else s = translateChar(tmp); if(s != CHAR(tmp)) SET_STRING_ELT(xx, i, mkChar(s)); } w = wd; if (adj != Rprt_adj_none) { for (i = 0; i < n; i++) if (STRING_ELT(xx, i) != NA_STRING) w = imax2(w, Rstrlen(STRING_ELT(xx, i), 0)); else if (na) w = imax2(w, R_print.na_width); } else w = 0; /* now calculate the buffer size needed, in bytes */ for (i = 0; i < n; i++) if (STRING_ELT(xx, i) != NA_STRING) { il = Rstrlen(STRING_ELT(xx, i), 0); cnt = imax2(cnt, LENGTH(STRING_ELT(xx, i)) + imax2(0, w-il)); } else if (na) cnt = imax2(cnt, R_print.na_width + imax2(0, w-R_print.na_width)); R_CheckStack2(cnt+1); char buff[cnt+1]; PROTECT(y = allocVector(STRSXP, n)); for (i = 0; i < n; i++) { if(!na && STRING_ELT(xx, i) == NA_STRING) { SET_STRING_ELT(y, i, NA_STRING); } else { q = buff; if(STRING_ELT(xx, i) == NA_STRING) s0 = R_print.na_string; else s0 = STRING_ELT(xx, i) ; s = CHAR(s0); il = Rstrlen(s0, 0); b = w - il; if(b > 0 && adj != Rprt_adj_left) { b0 = (adj == Rprt_adj_centre) ? b/2 : b; for(j = 0 ; j < b0 ; j++) *q++ = ' '; b -= b0; } for(j = 0; j < LENGTH(s0); j++) *q++ = *s++; if(b > 0 && adj != Rprt_adj_right) for(j = 0 ; j < b ; j++) *q++ = ' '; *q = '\0'; SET_STRING_ELT(y, i, mkChar(buff)); } } } UNPROTECT(2); /* xx , y */ PROTECT(y); break; default: error(_("Impossible mode ( x )")); y = R_NilValue;/* -Wall */ } } if((l = getAttrib(x, R_DimSymbol)) != R_NilValue) { setAttrib(y, R_DimSymbol, l); if((l = getAttrib(x, R_DimNamesSymbol)) != R_NilValue) setAttrib(y, R_DimNamesSymbol, l); } else if((l = getAttrib(x, R_NamesSymbol)) != R_NilValue) setAttrib(y, R_NamesSymbol, l); /* In case something else forgets to set PrintDefaults(), PR#14477 */ R_print.scipen = scikeep; UNPROTECT(1); /* y */ return y; }
SEXP MlomarC(SEXP y, SEXP n, SEXP d, SEXP calb, SEXP morder, SEXP span, SEXP cnst, SEXP ns) { double *d1,*d2,*d3,*d4,*d5,*d6,*d7,*d8,*d9; int *i1,*i2,*i3,*i4,*i5,*i6,*i7,*i8,*i9,*i10,*i11,*i12,*i13,*i14; SEXP ans = R_NilValue, mean = R_NilValue, var = R_NilValue, ld1 = R_NilValue, ld2 = R_NilValue; SEXP ms = R_NilValue, aicm = R_NilValue, mp = R_NilValue, aicc = R_NilValue, mf = R_NilValue, aic = R_NilValue, a = R_NilValue, e = R_NilValue, ks = R_NilValue, ke = R_NilValue, nns = R_NilValue; double *xmean, *xvar, *xaicm, *xaicc, *xaic, *xa, *xe = NULL; int *xld1, *xld2, *xms, *xmp , *xmf, *xks, *xke, *xnns = NULL; int i, nd, mo, ns0, k; d1 = NUMERIC_POINTER(y); i1 = INTEGER_POINTER(n); i2 = INTEGER_POINTER(d); d2 = NUMERIC_POINTER(calb); i3 = INTEGER_POINTER(morder); i4 = INTEGER_POINTER(span); i5 = INTEGER_POINTER(cnst); i6 = INTEGER_POINTER(ns); nd = *i2; mo = *i3; ns0 = *i6; k = nd*nd*ns0; PROTECT(ans = allocVector(VECSXP, 15)); SET_VECTOR_ELT(ans, 0, mean = allocVector(REALSXP, nd)); SET_VECTOR_ELT(ans, 1, var = allocVector(REALSXP, nd)); SET_VECTOR_ELT(ans, 2, ld1 = allocVector(INTSXP, ns0)); SET_VECTOR_ELT(ans, 3, ld2 = allocVector(INTSXP, ns0)); SET_VECTOR_ELT(ans, 4, ms = allocVector(INTSXP, ns0)); SET_VECTOR_ELT(ans, 5, aicm = allocVector(REALSXP, ns0)); SET_VECTOR_ELT(ans, 6, mp = allocVector(INTSXP, ns0)); SET_VECTOR_ELT(ans, 7, aicc = allocVector(REALSXP, ns0)); SET_VECTOR_ELT(ans, 8, mf = allocVector(INTSXP, ns0)); SET_VECTOR_ELT(ans, 9, aic = allocVector(REALSXP, ns0)); SET_VECTOR_ELT(ans, 10, a = allocVector(REALSXP, k*mo)); SET_VECTOR_ELT(ans, 11, e = allocVector(REALSXP, k)); SET_VECTOR_ELT(ans, 12, ks = allocVector(INTSXP, ns0)); SET_VECTOR_ELT(ans, 13, ke = allocVector(INTSXP, ns0)); SET_VECTOR_ELT(ans, 14, nns = allocVector(INTSXP, 1)); d3 = NUMERIC_POINTER(mean); d4 = NUMERIC_POINTER(var); i7 = INTEGER_POINTER(ld1); i8 = INTEGER_POINTER(ld2); i9 = INTEGER_POINTER(ms); d5 = NUMERIC_POINTER(aicm); i10 = INTEGER_POINTER(mp); d6 = NUMERIC_POINTER(aicc); i11 = INTEGER_POINTER(mf); d7 = NUMERIC_POINTER(aic); d8 = NUMERIC_POINTER(a); d9 = NUMERIC_POINTER(e); i12 = INTEGER_POINTER(ks); i13 = INTEGER_POINTER(ke); i14 = INTEGER_POINTER(nns); F77_CALL(mlomarf) (d1,i1,i2,d2,i3,i4,i5,i6,d3,d4,i7,i8,i9,d5,i10,d6,i11,d7,d8,d9,i12,i13,i14); xmean = REAL(mean); xvar = REAL(var); xld1 = INTEGER(ld1); xld2 = INTEGER(ld2); xms = INTEGER(ms); xaicm = REAL(aicm); xmp = INTEGER(mp); xaicc = REAL(aicc); xmf = INTEGER(mf); xaic = REAL(aic); xa = REAL(a); xe = REAL(e); xks = INTEGER(ks); xke = INTEGER(ke); xnns = INTEGER(nns); *xmean = *d3; *xvar = *d4; for(i=0; i<nd; i++) xld1[i] = i7[i]; for(i=0; i<nd; i++) xld2[i] = i8[i]; for(i=0; i<ns0; i++) xms[i] = i9[i]; for(i=0; i<ns0; i++) xaicm[i] = d5[i]; for(i=0; i<ns0; i++) xmp[i] = i10[i]; for(i=0; i<ns0; i++) xaicc[i] = d6[i]; for(i=0; i<ns0; i++) xmf[i] = i11[i]; for(i=0; i<ns0; i++) xaic[i] = d7[i]; for(i=0; i<k*mo; i++) xa[i] = d8[i]; for(i=0; i<k; i++) xe[i] = d9[i]; for(i=0; i<ns0; i++) xks[i] = i12[i]; for(i=0; i<ns0; i++) xke[i] = i13[i]; *xnns = *i14; UNPROTECT(1); return ans; }
SEXP bnstruct_heom_dist( SEXP sexp_vec, SEXP sexp_mat, SEXP sexp_num_var, SEXP sexp_num_var_range ) { // inputs int i,j; int nvar = ncols(sexp_mat); int nrow = nrows(sexp_mat); double * vec = REAL(sexp_vec); double * mat = REAL(sexp_mat); int * num_var = INTEGER(sexp_num_var); double * num_var_range = REAL(sexp_num_var_range); // allocate output and copy input SEXP result; PROTECT( result = allocVector(REALSXP, nrow) ); double * res = REAL(result); for( i = 0; i < nrow; i++ ) res[i] = 0; // internal structure int num_var_ind[nvar]; double num_var_range_ind[nvar]; for( i = 0; i < nvar; i++ ) { num_var_ind[i] = 0; num_var_range_ind[i] = 0; } for( i = 0; i < length(sexp_num_var); i++ ) { num_var_ind[ num_var[i] - 1 ] = 1; num_var_range_ind[ num_var[i] - 1 ] = num_var_range[i]; } // compute distances for( i = 0; i < nvar; i++ ) { if( ISNA(vec[i]) ) for( j = 0; j < nrow; j++ ) res[j] += 1; else if( num_var_ind[i] ) for( j = 0; j < nrow; j++ ) if( ISNA(mat[j + i*nrow]) ) res[j] += 1; else res[j] += pow( (vec[i] - mat[j + i*nrow]) / num_var_range_ind[i], 2 ); else for( j = 0; j < nrow; j++ ) if( ISNA(mat[j + i*nrow]) ) res[j] += 1; else res[j] += ( vec[i] != mat[j + i*nrow] ); } for( i = 0; i < nrow; i++ ) res[i] = sqrt(res[i]); UNPROTECT(1); return( result ); }
SEXP matrixApply(SEXP result, SEXP data, SEXP margin, SEXP function, int worldRank, int worldSize) { SEXP ans, data_size; MPI_Datatype row_type, column_type; MPI_Status status; int my_start, my_end, N, function_nlines, nvectors, offset; int local_check = 0, global_check = 0; int dimensions[2]; if (worldRank == MASTER_PROCESS) { data_size = GET_DIM(data); dimensions[0] = INTEGER_POINTER(data_size)[0]; dimensions[1] = INTEGER_POINTER(data_size)[1]; /* function SEXP object is a vector of strings, each element contains a single line of the function definition */ function_nlines = length(function); } MPI_Bcast(dimensions, 2, MPI_INT, 0, MPI_COMM_WORLD); MPI_Bcast(&function_nlines, 1, MPI_INT, 0, MPI_COMM_WORLD); /* margin provides the subscripts which the function will be applied over. "1" indicates rows, "2" indicates columns, c(1,2)" indicates rows and columns */ if(worldRank != MASTER_PROCESS) PROTECT(margin = allocVector(INTSXP, 1)); MPI_Bcast(INTEGER(margin), 1, MPI_INT, 0, MPI_COMM_WORLD); /* Matrix dimensions in R are interpreted differen than in C. We will refer to R rows and columns ordering, so rows are not alligned in memory */ if (INTEGER(margin)[0] == 1) { N = dimensions[0]; /* define vector type type to handle R rows exchange (count, blocklength, stride)*/ MPI_Type_vector (dimensions[1], 1, dimensions[0], MPI_DOUBLE, &row_type); MPI_Type_commit (&row_type); } else if (INTEGER(margin)[0] == 2) { N = dimensions[1]; /* define contiguous type to handle R columns exchange */ MPI_Type_contiguous(dimensions[0], MPI_DOUBLE, &column_type); MPI_Type_commit(&column_type); } else if (INTEGER(margin)[0] == 3) { // TODO DEBUG("Margin number 3 not yet implemented\n"); return R_NilValue; } else { DEBUG("Don't know how to deal with margin number %d\n", INTEGER(margin)[0]); return R_NilValue; } if(worldRank != MASTER_PROCESS) { /* Allocate memory for SEXP objects on worker nodes. alloc... functions do their own error-checking and return if the allocation process will fail. */ loopDistribute(worldRank, worldSize, N, &my_start, &my_end); if (INTEGER(margin)[0] == 1) PROTECT(data = allocMatrix(REALSXP, my_end-my_start, dimensions[1])); if (INTEGER(margin)[0] == 2) PROTECT(data = allocMatrix(REALSXP, dimensions[0], my_end-my_start)); PROTECT(function = allocVector(STRSXP, function_nlines)); } if ( (data == NULL) || (function == NULL) ) { local_check = 1; } else { local_check = 0; } /* Check whether memory was successfully allocated on all worker nodes */ MPI_Allreduce(&local_check, &global_check, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); /* No need to free memory if allocation fails on one of the workers R_alloc will release it after .Call returns to R */ if ( global_check != 0 ) { /* Remove all references from the stack, I'm not sure if this is necessary */ if(worldRank != MASTER_PROCESS) UNPROTECT(3); return ScalarInteger(-1); } /* Distribute data between processes */ for (int worker_id=1; worker_id<worldSize; worker_id++) { if (worldRank == MASTER_PROCESS) { /* Calculate expected message length for each worker */ loopDistribute(worker_id, worldSize, N, &my_start, &my_end); nvectors = my_end - my_start; /* If we applying over rows, as defined in R, we need to use the MPI vector type sending each row as a separate message */ if (INTEGER(margin)[0] == 1) { for(int k=0; k<nvectors; k++) { offset = my_start+k; MPI_Send(&REAL(data)[offset], 1, row_type, worker_id, 0, MPI_COMM_WORLD); } } /* R defined columns are alligned in memory, single message of build from contiguous column_type elemensts is send */ else if (INTEGER(margin)[0] == 2) { offset = my_start*dimensions[0]; MPI_Send(&REAL(data)[offset], nvectors, column_type, worker_id, 0, MPI_COMM_WORLD); } } else if (worldRank == worker_id) { nvectors = my_end - my_start; if (INTEGER(margin)[0] == 1) { for(int k=0; k<nvectors; k++) { offset = k*dimensions[1]; MPI_Recv(&REAL(data)[offset], dimensions[1], MPI_DOUBLE, MASTER_PROCESS, 0, MPI_COMM_WORLD, &status); } } else if (INTEGER(margin)[0] == 2) { MPI_Recv(REAL(data), nvectors, column_type, MASTER_PROCESS, 0, MPI_COMM_WORLD, &status); } } } /* Redo loop distribution for the Master process */ if (worldRank == MASTER_PROCESS) { loopDistribute(worldRank, worldSize, N, &my_start, &my_end); } /* Bcast function name or definition, cover case when definition is split into several lines and stored as a SEXP string vector */ bcastRFunction(function, function_nlines, worldRank); /* Response container, Vector of SEXPs, margin determines vector length */ PROTECT(ans = allocVector(VECSXP, N)); do_matrixApply(ans, data, margin, function, my_start, my_end, dimensions, worldRank); gatherData(result, ans, N, my_start, my_end, worldRank); if(worldRank != MASTER_PROCESS) { UNPROTECT(4); } else { UNPROTECT(1); } return result; }
/* 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; }
/* A generic recv wrapper function */ SEXP SOCK_RECV(SEXP S, SEXP EXT, SEXP BS, SEXP MAXBUFSIZE) { SEXP ans = R_NilValue; void *buf; char *msg, *p; // struct pollfd pfds; int j, s = INTEGER(S)[0]; size_t k = 0; double maxbufsize = REAL(MAXBUFSIZE)[0]; int bufsize = MBUF; int bs = INTEGER(BS)[0]; if(maxbufsize < bs) maxbufsize = bs; buf = (void *)malloc(bs); msg = (char *)malloc(bs); p = msg; // pfds.fd = s; // pfds.events = POLLIN; // h = poll(&pfds, 1, 50); // while(h>0) { j = 1; while(j>=0) { #ifdef WIN32 j = recv((SOCKET)s, buf, bs, 0); #else j = recv(s, buf, bs, 0); #endif if(j<1) break; /* If we exceed the maxbufsize, break. This leaves data * in the TCP RX buffer. XXX We need to tell R that this * is an incomplete read so this can be handled at a high * level, for example by closing the connection or whatever. * The code is here for basic protection from DoS and memory * overcommit attacks. */ if(k+j > maxbufsize) break; if(k + j > bufsize) { bufsize = bufsize + MBUF; msg = (char *)realloc(msg, bufsize); } p = msg + k; memcpy((void *)p, buf, j); k = k + j; // h=poll(&pfds, 1, 50); } if(INTEGER(EXT)[0]) { /* return a pointer to the recv buffer */ ans = R_MakeExternalPtr ((void *)msg, R_NilValue, R_NilValue); R_RegisterCFinalizer (ans, recv_finalize); free(buf); } else { /* Copy to a raw vector */ PROTECT(ans=allocVector(RAWSXP,k)); p = (char *)RAW(ans); memcpy((void *)p, (void *)msg, k); free(buf); free(msg); UNPROTECT(1); } return ans; }
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 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); }
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)); }
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 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); }
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; }
/* * The following returns a R list with the following components: * currentStreams * currentLogWeights * propUniqueStreamIds */ static SEXP resamp_func_builtin_PPW (Sampler *ss, int currentPeriod, SEXP currentStreams, SEXP currentLogWeights) { ResampleContext *rc = ss->scratch_RC; int nspr = ss->nStreamsPreResamp, dpp = ss->dimPerPeriod; int ns = ss->nStreams, *sids = rc->streamIds, ii, jj, kk; int nusids, *usids = rc->uniqueStreamIds; int nComps = 0, nProtected = 0; double *ps = rc->partialSum; double sum, uu; SEXP resampCurrentStreams, resampCurrentLogWeights, resampPropUniqueStreamIds; SEXP retList, names; double *rcs, *rclw; double *scs = REAL(currentStreams); double *sclw = REAL(currentLogWeights); double *scaw = REAL(ss->SEXPCurrentAdjWeights); void *vmax = vmaxget( ); PROTECT(resampCurrentStreams = allocMatrix(REALSXP, ns, dpp)); ++nComps; ++nProtected; PROTECT(resampCurrentLogWeights = allocVector(REALSXP, ns)); ++nComps; ++nProtected; rcs = REAL(resampCurrentStreams); rclw = REAL(resampCurrentLogWeights); sampler_adjust_log_weights(nspr, sclw, scaw); ps[0] = scaw[0]; for (jj = 1; jj < nspr; ++jj) { ps[jj] = ps[jj - 1] + scaw[jj]; } sum = ps[nspr - 1]; nusids = 0; /* resample the streams with probability proportional to their * weights */ for (jj = 0; jj < ns; ++jj) { uu = runif(0, sum); for (ii = 0; ii < nspr; ++ii) { if (uu <= ps[ii]) { sids[jj] = ii; break; } } /* copying the resampled stream */ for (kk = 0; kk < dpp; ++kk) rcs[kk * ns + jj] = scs[kk * nspr + sids[jj]]; /* making the resampled logWeights = 0 */ rclw[jj] = 0; /* find the unique stream and register it */ if (utils_is_int_in_iarray(sids[jj], nusids, usids) == FALSE) { usids[nusids] = sids[jj]; ++nusids; } } rc->nUniqueStreamIds = nusids; rc->propUniqueStreamIds = nusids / ((double) nspr); PROTECT(resampPropUniqueStreamIds = allocVector(REALSXP, 1)); ++nComps; ++nProtected; REAL(resampPropUniqueStreamIds)[0] = rc->propUniqueStreamIds; PROTECT(retList = allocVector(VECSXP, nComps)); ++nProtected; PROTECT(names = allocVector(STRSXP, nComps)); ++nProtected; nComps = 0; SET_VECTOR_ELT(retList, nComps, resampCurrentStreams); SET_STRING_ELT(names, nComps, mkChar("currentStreams")); ++nComps; SET_VECTOR_ELT(retList, nComps, resampCurrentLogWeights); SET_STRING_ELT(names, nComps, mkChar("currentLogWeights")); ++nComps; SET_VECTOR_ELT(retList, nComps, resampPropUniqueStreamIds); SET_STRING_ELT(names, nComps, mkChar("propUniqueStreamIds")); setAttrib(retList, R_NamesSymbol, names); UNPROTECT(nProtected); vmaxset(vmax); return retList; }
SEXP attribute_hidden do_nchar(SEXP call, SEXP op, SEXP args, SEXP env) { SEXP d, s, x, stype; R_xlen_t i, len; int allowNA; size_t ntype; int nc; const char *type; const char *xi; wchar_t *wc; const void *vmax; checkArity(op, args); if (isFactor(CAR(args))) error(_("'%s' requires a character vector"), "nchar()"); PROTECT(x = coerceVector(CAR(args), STRSXP)); if (!isString(x)) error(_("'%s' requires a character vector"), "nchar()"); len = XLENGTH(x); stype = CADR(args); if (!isString(stype) || LENGTH(stype) != 1) error(_("invalid '%s' argument"), "type"); type = CHAR(STRING_ELT(stype, 0)); /* always ASCII */ ntype = strlen(type); if (ntype == 0) error(_("invalid '%s' argument"), "type"); allowNA = asLogical(CADDR(args)); if (allowNA == NA_LOGICAL) allowNA = 0; PROTECT(s = allocVector(INTSXP, len)); vmax = vmaxget(); for (i = 0; i < len; i++) { SEXP sxi = STRING_ELT(x, i); if (sxi == NA_STRING) { INTEGER(s)[i] = 2; continue; } if (strncmp(type, "bytes", ntype) == 0) { INTEGER(s)[i] = LENGTH(sxi); } else if (strncmp(type, "chars", ntype) == 0) { if (IS_UTF8(sxi)) { /* assume this is valid */ const char *p = CHAR(sxi); nc = 0; for( ; *p; p += utf8clen(*p)) nc++; INTEGER(s)[i] = nc; } else if (IS_BYTES(sxi)) { if (!allowNA) /* could do chars 0 */ error(_("number of characters is not computable for element %d in \"bytes\" encoding"), i+1); INTEGER(s)[i] = NA_INTEGER; } else if (mbcslocale) { nc = (int) mbstowcs(NULL, translateChar(sxi), 0); if (!allowNA && nc < 0) error(_("invalid multibyte string %d"), i+1); INTEGER(s)[i] = nc >= 0 ? nc : NA_INTEGER; } else INTEGER(s)[i] = (int) strlen(translateChar(sxi)); } else if (strncmp(type, "width", ntype) == 0) { if (IS_UTF8(sxi)) { /* assume this is valid */ const char *p = CHAR(sxi); wchar_t wc1; nc = 0; for( ; *p; p += utf8clen(*p)) { utf8toucs(&wc1, p); nc += Ri18n_wcwidth(wc1); } INTEGER(s)[i] = nc; } else if (IS_BYTES(sxi)) { if (!allowNA) /* could do width 0 */ error(_("width is not computable for element %d in \"bytes\" encoding"), i+1); INTEGER(s)[i] = NA_INTEGER; } else if (mbcslocale) { xi = translateChar(sxi); nc = (int) mbstowcs(NULL, xi, 0); if (nc >= 0) { wc = (wchar_t *) R_AllocStringBuffer((nc+1)*sizeof(wchar_t), &cbuff); mbstowcs(wc, xi, nc + 1); INTEGER(s)[i] = Ri18n_wcswidth(wc, 2147483647); if (INTEGER(s)[i] < 1) INTEGER(s)[i] = nc; } else if (allowNA) error(_("invalid multibyte string %d"), i+1); else INTEGER(s)[i] = NA_INTEGER; } else INTEGER(s)[i] = (int) strlen(translateChar(sxi)); } else error(_("invalid '%s' argument"), "type"); vmaxset(vmax); } R_FreeStringBufferL(&cbuff); if ((d = getAttrib(x, R_NamesSymbol)) != R_NilValue) setAttrib(s, R_NamesSymbol, d); if ((d = getAttrib(x, R_DimSymbol)) != R_NilValue) setAttrib(s, R_DimSymbol, d); if ((d = getAttrib(x, R_DimNamesSymbol)) != R_NilValue) setAttrib(s, R_DimNamesSymbol, d); UNPROTECT(2); return s; }
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 attribute_hidden do_substrgets(SEXP call, SEXP op, SEXP args, SEXP env) { SEXP s, x, sa, so, value, el, v_el; R_xlen_t i, len; int start, stop, k, l, v; size_t slen; cetype_t ienc, venc; const char *ss, *v_ss; char *buf; const void *vmax; checkArity(op, args); x = CAR(args); sa = CADR(args); so = CADDR(args); value = CADDDR(args); k = LENGTH(sa); l = LENGTH(so); if (!isString(x)) error(_("replacing substrings in a non-character object")); len = LENGTH(x); PROTECT(s = allocVector(STRSXP, len)); if (len > 0) { if (!isInteger(sa) || !isInteger(so) || k == 0 || l == 0) error(_("invalid substring arguments")); v = LENGTH(value); if (!isString(value) || v == 0) error(_("invalid value")); vmax = vmaxget(); for (i = 0; i < len; i++) { el = STRING_ELT(x, i); v_el = STRING_ELT(value, i % v); start = INTEGER(sa)[i % k]; stop = INTEGER(so)[i % l]; if (el == NA_STRING || v_el == NA_STRING || start == NA_INTEGER || stop == NA_INTEGER) { SET_STRING_ELT(s, i, NA_STRING); continue; } ienc = getCharCE(el); ss = CHAR(el); slen = strlen(ss); if (start < 1) start = 1; if (stop > slen) stop = (int) slen; /* SBCS optimization */ if (start > stop) { /* just copy element across */ SET_STRING_ELT(s, i, STRING_ELT(x, i)); } else { int ienc2 = ienc; v_ss = CHAR(v_el); /* is the value in the same encoding? FIXME: could prefer UTF-8 here */ venc = getCharCE(v_el); if (venc != ienc && !strIsASCII(v_ss)) { ss = translateChar(el); slen = strlen(ss); v_ss = translateChar(v_el); ienc2 = CE_NATIVE; } /* might expand under MBCS */ buf = R_AllocStringBuffer(slen+strlen(v_ss), &cbuff); strcpy(buf, ss); substrset(buf, v_ss, ienc2, start, stop); SET_STRING_ELT(s, i, mkCharCE(buf, ienc2)); } vmaxset(vmax); } R_FreeStringBufferL(&cbuff); } UNPROTECT(1); return s; }
SEXP spPPGLM(SEXP Y_r, SEXP X_r, SEXP p_r, SEXP n_r, SEXP family_r, SEXP weights_r, SEXP m_r, SEXP knotsD_r, SEXP knotsCoordsD_r, SEXP betaPrior_r, SEXP betaNorm_r, SEXP sigmaSqIG_r, SEXP nuUnif_r, SEXP phiUnif_r, SEXP phiStarting_r, SEXP sigmaSqStarting_r, SEXP nuStarting_r, SEXP betaStarting_r, SEXP w_strStarting_r, SEXP phiTuning_r, SEXP sigmaSqTuning_r, SEXP nuTuning_r, SEXP betaTuning_r, SEXP w_strTuning_r, SEXP covModel_r, SEXP nSamples_r, SEXP verbose_r, SEXP nReport_r){ /***************************************** Common variables *****************************************/ int i,j,k,l,info,nProtect= 0; char const *lower = "L"; char const *upper = "U"; char const *ntran = "N"; char const *ytran = "T"; char const *rside = "R"; char const *lside = "L"; const double one = 1.0; const double negOne = -1.0; const double zero = 0.0; const int incOne = 1; /***************************************** Set-up *****************************************/ double *Y = REAL(Y_r); double *X = REAL(X_r); int p = INTEGER(p_r)[0]; int pp = p*p; int n = INTEGER(n_r)[0]; std::string family = CHAR(STRING_ELT(family_r,0)); int *weights = INTEGER(weights_r); //covariance model std::string covModel = CHAR(STRING_ELT(covModel_r,0)); int m = INTEGER(m_r)[0]; double *knotsD = REAL(knotsD_r); double *knotsCoordsD = REAL(knotsCoordsD_r); //priors and starting std::string betaPrior = CHAR(STRING_ELT(betaPrior_r,0)); double *betaMu = NULL; double *betaSd = NULL; if(betaPrior == "normal"){ betaMu = REAL(VECTOR_ELT(betaNorm_r, 0)); betaSd = REAL(VECTOR_ELT(betaNorm_r, 1)); } double *sigmaSqIG = REAL(sigmaSqIG_r); double *phiUnif = REAL(phiUnif_r); double phiStarting = REAL(phiStarting_r)[0]; double sigmaSqStarting = REAL(sigmaSqStarting_r)[0]; double *betaStarting = REAL(betaStarting_r); double *w_strStarting = REAL(w_strStarting_r); double sigmaSqIGa = sigmaSqIG[0]; double sigmaSqIGb = sigmaSqIG[1]; double phiUnifa = phiUnif[0]; double phiUnifb = phiUnif[1]; //if matern double *nuUnif = NULL; double nuStarting = 0; double nuUnifa = 0, nuUnifb = 0; if(covModel == "matern"){ nuUnif = REAL(nuUnif_r); nuStarting = REAL(nuStarting_r)[0]; nuUnifa = nuUnif[0]; nuUnifb = nuUnif[1]; } //tuning double *betaTuning = (double *) R_alloc(p*p, sizeof(double)); F77_NAME(dcopy)(&pp, REAL(betaTuning_r), &incOne, betaTuning, &incOne); double phiTuning = sqrt(REAL(phiTuning_r)[0]); double sigmaSqTuning = sqrt(REAL(sigmaSqTuning_r)[0]); double *w_strTuning = REAL(w_strTuning_r); double nuTuning = 0; if(covModel == "matern") nuTuning = sqrt(REAL(nuTuning_r)[0]); int nSamples = INTEGER(nSamples_r)[0]; int verbose = INTEGER(verbose_r)[0]; int nReport = INTEGER(nReport_r)[0]; if(verbose){ Rprintf("----------------------------------------\n"); Rprintf("\tGeneral model description\n"); Rprintf("----------------------------------------\n"); Rprintf("Model fit with %i observations.\n\n", n); Rprintf("Number of covariates %i (including intercept if specified).\n\n", p); Rprintf("Using the %s spatial correlation model.\n\n", covModel.c_str()); Rprintf("Using non-modified predictive process with %i knots.\n\n", m); Rprintf("Number of MCMC samples %i.\n\n", nSamples); Rprintf("Priors and hyperpriors:\n"); if(betaPrior == "flat"){ Rprintf("\tbeta flat.\n"); }else{ Rprintf("\tbeta normal:\n"); Rprintf("\t\tmu:"); printVec(betaMu, p); Rprintf("\t\tsd:"); printVec(betaSd, p);Rprintf("\n"); } Rprintf("\n"); Rprintf("\tsigma.sq IG hyperpriors shape=%.5f and scale=%.5f\n", sigmaSqIGa, sigmaSqIGb); Rprintf("\n"); Rprintf("\tphi Unif hyperpriors a=%.5f and b=%.5f\n", phiUnifa, phiUnifb); Rprintf("\n"); if(covModel == "matern"){ Rprintf("\tnu Unif hyperpriors a=%.5f and b=%.5f\n", nuUnifa, nuUnifb); } Rprintf("Metropolis tuning values:\n"); Rprintf("\tbeta tuning:\n"); printMtrx(betaTuning, p, p); Rprintf("\n"); Rprintf("\tsigma.sq tuning: %.5f\n", sigmaSqTuning); Rprintf("\n"); Rprintf("\tphi tuning: %.5f\n", phiTuning); Rprintf("\n"); if(covModel == "matern"){ Rprintf("\tnu tuning: %.5f\n", nuTuning); Rprintf("\n"); } Rprintf("Metropolis starting values:\n"); Rprintf("\tbeta starting:\n"); Rprintf("\t"); printVec(betaStarting, p); Rprintf("\n"); Rprintf("\tsigma.sq starting: %.5f\n", sigmaSqStarting); Rprintf("\n"); Rprintf("\tphi starting: %.5f\n", phiStarting); Rprintf("\n"); if(covModel == "matern"){ Rprintf("\tnu starting: %.5f\n", nuStarting); Rprintf("\n"); } } /***************************************** Set-up MCMC sample matrices etc. *****************************************/ int nn = n*n, nm = n*m, mm = m*m; //spatial parameters int nParams, betaIndx, sigmaSqIndx, phiIndx, nuIndx; if(covModel != "matern"){ nParams = p+2;//sigma^2, phi betaIndx = 0; sigmaSqIndx = betaIndx+p; phiIndx = sigmaSqIndx+1; }else{ nParams = p+3;//sigma^2, phi, nu betaIndx = 0; sigmaSqIndx = betaIndx+p; phiIndx = sigmaSqIndx+1; nuIndx = phiIndx+1; } double *spParams = (double *) R_alloc(nParams, sizeof(double)); //set starting F77_NAME(dcopy)(&p, betaStarting, &incOne, &spParams[betaIndx], &incOne); spParams[sigmaSqIndx] = log(sigmaSqStarting); spParams[phiIndx] = logit(phiStarting, phiUnifa, phiUnifb); if(covModel == "matern") spParams[nuIndx] = logit(nuStarting, nuUnifa, nuUnifb); double *wCurrent = (double *) R_alloc(n, sizeof(double)); double *w_strCurrent = (double *) R_alloc(m, sizeof(double)); F77_NAME(dcopy)(&m, w_strStarting, &incOne, w_strCurrent, &incOne); //samples and random effects SEXP w_r, w_str_r, samples_r, accept_r; PROTECT(w_r = allocMatrix(REALSXP, n, nSamples)); nProtect++; double *w = REAL(w_r); zeros(w, n*nSamples); PROTECT(w_str_r = allocMatrix(REALSXP, m, nSamples)); nProtect++; double *w_str = REAL(w_str_r); zeros(w_str, m*nSamples); PROTECT(samples_r = allocMatrix(REALSXP, nParams, nSamples)); nProtect++; double *samples = REAL(samples_r); PROTECT(accept_r = allocMatrix(REALSXP, 1, 1)); nProtect++; /***************************************** Set-up MCMC alg. vars. matrices etc. *****************************************/ int s=0, status=0, rtnStatus=0, accept=0, batchAccept = 0; double logPostCurrent = 0, logPostCand = 0, detCand = 0; double *P = (double *) R_alloc(nm, sizeof(double)); double *K = (double *) R_alloc(mm, sizeof(double)); double *tmp_n = (double *) R_alloc(n, sizeof(double)); double *tmp_m = (double *) R_alloc(m, sizeof(double)); double *tmp_nm = (double *) R_alloc(nm, sizeof(double)); double *theta = (double *) R_alloc(3, sizeof(double)); //phi, nu, and perhaps more in the future double *candSpParams = (double *) R_alloc(nParams, sizeof(double)); double *w_strCand = (double *) R_alloc(m, sizeof(double)); double *wCand = (double *) R_alloc(n, sizeof(double)); double sigmaSq, phi, nu; double *beta = (double *) R_alloc(p, sizeof(double)); double logMHRatio; if(verbose){ Rprintf("-------------------------------------------------\n"); Rprintf("\t\tSampling\n"); Rprintf("-------------------------------------------------\n"); #ifdef Win32 R_FlushConsole(); #endif } logPostCurrent = R_NegInf; GetRNGstate(); for(s = 0; s < nSamples; s++){ //propose mvrnorm(&candSpParams[betaIndx], &spParams[betaIndx], betaTuning, p, false); F77_NAME(dcopy)(&p, &candSpParams[betaIndx], &incOne, beta, &incOne); candSpParams[sigmaSqIndx] = rnorm(spParams[sigmaSqIndx], sigmaSqTuning); sigmaSq = theta[0] = exp(candSpParams[sigmaSqIndx]); candSpParams[phiIndx] = rnorm(spParams[phiIndx], phiTuning); phi = theta[1] = logitInv(candSpParams[phiIndx], phiUnifa, phiUnifb); if(covModel == "matern"){ candSpParams[nuIndx] = rnorm(spParams[nuIndx], nuTuning); nu = theta[2] = logitInv(candSpParams[nuIndx], nuUnifa, nuUnifb); } for(i = 0; i < m; i++){ w_strCand[i] = rnorm(w_strCurrent[i], sqrt(w_strTuning[i])); } //construct covariance matrices spCovLT(knotsD, m, theta, covModel, K); spCov(knotsCoordsD, nm, theta, covModel, P); //invert C and log det cov detCand = 0; F77_NAME(dpotrf)(lower, &m, K, &m, &info); if(info != 0){error("c++ error: Cholesky failed in spGLM\n");} for(i = 0; i < m; i++) detCand += 2*log(K[i*m+i]); F77_NAME(dpotri)(lower, &m, K, &m, &info); if(info != 0){error("c++ error: Cholesky inverse failed in spGLM\n");} //make \tild{w} F77_NAME(dsymv)(lower, &m, &one, K, &m, w_strCand, &incOne, &zero, tmp_m, &incOne); F77_NAME(dgemv)(ytran, &m, &n, &one, P, &m, tmp_m, &incOne, &zero, wCand, &incOne); //Likelihood with Jacobian logPostCand = 0.0; if(betaPrior == "normal"){ for(i = 0; i < p; i++){ logPostCand += dnorm(beta[i], betaMu[i], betaSd[i], 1); } } logPostCand += -1.0*(1.0+sigmaSqIGa)*log(sigmaSq)-sigmaSqIGb/sigmaSq+log(sigmaSq); logPostCand += log(phi - phiUnifa) + log(phiUnifb - phi); if(covModel == "matern"){ logPostCand += log(nu - nuUnifa) + log(nuUnifb - nu); } F77_NAME(dgemv)(ntran, &n, &p, &one, X, &n, beta, &incOne, &zero, tmp_n, &incOne); if(family == "binomial"){ logPostCand += binomial_logpost(n, Y, tmp_n, wCand, weights); }else if(family == "poisson"){ logPostCand += poisson_logpost(n, Y, tmp_n, wCand, weights); }else{ error("c++ error: family misspecification in spGLM\n"); } //(-1/2) * tmp_n` * C^-1 * tmp_n logPostCand += -0.5*detCand-0.5*F77_NAME(ddot)(&m, w_strCand, &incOne, tmp_m, &incOne); // //MH accept/reject // //MH ratio with adjustment logMHRatio = logPostCand - logPostCurrent; if(runif(0.0,1.0) <= exp(logMHRatio)){ F77_NAME(dcopy)(&nParams, candSpParams, &incOne, spParams, &incOne); F77_NAME(dcopy)(&n, wCand, &incOne, wCurrent, &incOne); F77_NAME(dcopy)(&m, w_strCand, &incOne, w_strCurrent, &incOne); logPostCurrent = logPostCand; accept++; batchAccept++; } /****************************** Save samples and report *******************************/ F77_NAME(dcopy)(&nParams, spParams, &incOne, &samples[s*nParams], &incOne); F77_NAME(dcopy)(&n, wCurrent, &incOne, &w[s*n], &incOne); F77_NAME(dcopy)(&m, w_strCurrent, &incOne, &w_str[s*m], &incOne); //report if(verbose){ if(status == nReport){ Rprintf("Sampled: %i of %i, %3.2f%%\n", s, nSamples, 100.0*s/nSamples); Rprintf("Report interval Metrop. Acceptance rate: %3.2f%%\n", 100.0*batchAccept/nReport); Rprintf("Overall Metrop. Acceptance rate: %3.2f%%\n", 100.0*accept/s); Rprintf("-------------------------------------------------\n"); #ifdef Win32 R_FlushConsole(); #endif status = 0; batchAccept = 0; } } status++; R_CheckUserInterrupt(); }//end sample loop PutRNGstate(); //final status report if(verbose){ Rprintf("Sampled: %i of %i, %3.2f%%\n", s, nSamples, 100.0*s/nSamples); Rprintf("-------------------------------------------------\n"); #ifdef Win32 R_FlushConsole(); #endif } //untransform variance variables for(s = 0; s < nSamples; s++){ samples[s*nParams+sigmaSqIndx] = exp(samples[s*nParams+sigmaSqIndx]); samples[s*nParams+phiIndx] = logitInv(samples[s*nParams+phiIndx], phiUnifa, phiUnifb); if(covModel == "matern") samples[s*nParams+nuIndx] = logitInv(samples[s*nParams+nuIndx], nuUnifa, nuUnifb); } //calculate acceptance rate REAL(accept_r)[0] = 100.0*accept/s; //make return object SEXP result, resultNames; int nResultListObjs = 4; PROTECT(result = allocVector(VECSXP, nResultListObjs)); nProtect++; PROTECT(resultNames = allocVector(VECSXP, nResultListObjs)); nProtect++; //samples SET_VECTOR_ELT(result, 0, samples_r); SET_VECTOR_ELT(resultNames, 0, mkChar("p.beta.theta.samples")); SET_VECTOR_ELT(result, 1, accept_r); SET_VECTOR_ELT(resultNames, 1, mkChar("acceptance")); SET_VECTOR_ELT(result, 2, w_r); SET_VECTOR_ELT(resultNames, 2, mkChar("p.w.samples")); SET_VECTOR_ELT(result, 3, w_str_r); SET_VECTOR_ELT(resultNames, 3, mkChar("p.w.knots.samples")); namesgets(result, resultNames); //unprotect UNPROTECT(nProtect); return(result); }
SEXP attribute_hidden do_makenames(SEXP call, SEXP op, SEXP args, SEXP env) { SEXP arg, ans; R_xlen_t i, n; int l, allow_; char *p, *tmp = NULL, *cbuf; const char *This; Rboolean need_prefix; const void *vmax; checkArity(op ,args); arg = CAR(args); if (!isString(arg)) error(_("non-character names")); n = XLENGTH(arg); allow_ = asLogical(CADR(args)); if (allow_ == NA_LOGICAL) error(_("invalid '%s' value"), "allow_"); PROTECT(ans = allocVector(STRSXP, n)); vmax = vmaxget(); for (i = 0 ; i < n ; i++) { This = translateChar(STRING_ELT(arg, i)); l = (int) strlen(This); /* need to prefix names not beginning with alpha or ., as well as . followed by a number */ need_prefix = FALSE; if (mbcslocale && This[0]) { int nc = l, used; wchar_t wc; mbstate_t mb_st; const char *pp = This; mbs_init(&mb_st); used = (int) Mbrtowc(&wc, pp, MB_CUR_MAX, &mb_st); pp += used; nc -= used; if (wc == L'.') { if (nc > 0) { Mbrtowc(&wc, pp, MB_CUR_MAX, &mb_st); if (iswdigit(wc)) need_prefix = TRUE; } } else if (!iswalpha(wc)) need_prefix = TRUE; } else { if (This[0] == '.') { if (l >= 1 && isdigit(0xff & (int) This[1])) need_prefix = TRUE; } else if (!isalpha(0xff & (int) This[0])) need_prefix = TRUE; } if (need_prefix) { tmp = Calloc(l+2, char); strcpy(tmp, "X"); strcat(tmp, translateChar(STRING_ELT(arg, i))); } else { tmp = Calloc(l+1, char); strcpy(tmp, translateChar(STRING_ELT(arg, i))); } if (mbcslocale) { /* This cannot lengthen the string, so safe to overwrite it. Would also be possible a char at a time. */ int nc = (int) mbstowcs(NULL, tmp, 0); wchar_t *wstr = Calloc(nc+1, wchar_t), *wc; if (nc >= 0) { mbstowcs(wstr, tmp, nc+1); for (wc = wstr; *wc; wc++) { if (*wc == L'.' || (allow_ && *wc == L'_')) /* leave alone */; else if (!iswalnum((int)*wc)) *wc = L'.'; /* If it changes into dot here, * length will become short on mbcs. * The name which became short will contain garbage. * cf. * > make.names(c("\u30fb")) * [1] "X.\0" */ } wcstombs(tmp, wstr, strlen(tmp)+1); Free(wstr); } else error(_("invalid multibyte string %d"), i+1); } else { for (p = tmp; *p; p++) {
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 Win_selectlist(SEXP args) { SEXP choices, preselect, ans = R_NilValue; const char **clist; int i, j = -1, n, mw = 0, multiple, nsel = 0; int xmax, ymax, ylist, fht, h0; Rboolean haveTitle; choices = CAR(args); if(!isString(choices)) error(_("invalid '%s' argument"), "choices"); preselect = CADR(args); if(!isNull(preselect) && !isString(preselect)) error(_("invalid '%s' argument"), "preselect"); multiple = asLogical(CADDR(args)); if(multiple == NA_LOGICAL) multiple = 0; haveTitle = isString(CADDDR(args)); if(!multiple && isString(preselect) && LENGTH(preselect) != 1) error(_("invalid '%s' argument"), "preselect"); n = LENGTH(choices); clist = (const char **) R_alloc(n + 1, sizeof(char *)); for(i = 0; i < n; i++) { clist[i] = translateChar(STRING_ELT(choices, i)); mw = max(mw, gstrwidth(NULL, SystemFont, clist[i])); } clist[n] = NULL; fht = getSysFontSize().height; xmax = max(170, mw+60); /* allow for scrollbar */ if(ismdi()) { RECT *pR = RgetMDIsize(); h0 = pR->bottom; } else { h0 = deviceheight(NULL); } ymax = min(80+fht*n, h0-100); /* allow for window widgets, toolbar */ ylist = ymax - 60; wselect = newwindow(haveTitle ? translateChar(STRING_ELT(CADDDR(args), 0)): (multiple ? _("Select one or more") : _("Select one")), rect(0, 0, xmax, ymax), Titlebar | Centered | Modal | Floating); setbackground(wselect, dialog_bg()); if(multiple) f_list = newmultilist(clist, rect(10, 10, xmax-25, ylist), NULL, finish); else f_list = newlistbox(clist, rect(10, 10, xmax-25, ylist), NULL, finish); if(!isNull(preselect) && LENGTH(preselect)) { for(i = 0; i < n; i++) for(j = 0; j < LENGTH(preselect); j++) if(strcmp(clist[i], translateChar(STRING_ELT(preselect, j))) == 0) { setlistitem(f_list, i); break; } } bFinish = newbutton(G_("OK"), rect(xmax-160, ymax-40, 70, 25), finish); bCancel = newbutton(G_("Cancel"), rect(xmax-80, ymax-40, 70, 25), cancel); setkeydown(wselect, key1); show(wselect); done = 0; while(!done) { R_WaitEvent(); R_ProcessEvents(); } if(multiple) { if (done == 1) { /* Finish */ for(i = 0; i < n; i++) if(isselected(f_list, i)) nsel++; PROTECT(ans = allocVector(STRSXP, nsel)); for(i = 0, j = 0; i < n; i++) if(isselected(f_list, i)) SET_STRING_ELT(ans, j++, mkChar(clist[i])); } else { /* cancel */ PROTECT(ans = allocVector(STRSXP, 0)); } } else PROTECT(ans = mkString(selected)); cleanup(); show(RConsole); R_ProcessEvents(); UNPROTECT(1); return ans; }