// This is used when we have a NimArr<>* in a model and a NimArr<>** that needs to point to it. // We assume we have an extptr to each SEXP setDoublePtrFromSinglePtr(SEXP SdoublePtr, SEXP SsinglePtr) { void *singlePtr = R_ExternalPtrAddr(SsinglePtr); // this is really a ** void **doublePtr = static_cast<void **>(R_ExternalPtrAddr(SdoublePtr)); // this is really a ***. *doublePtr = singlePtr; return(R_NilValue); }
SEXP processJSONNode(JSONNODE *n, int parentType, int simplify, SEXP nullValue, int simplifyWithNames, cetype_t charEncoding, SEXP r_stringCall, StringFunctionType str_fun_type) { if (n == NULL){ PROBLEM "invalid JSON input" ERROR; } JSONNODE *i; int len = 0, ctr = 0; int nprotect = 0; int numNulls = 0; len = json_size(n); char startType = parentType; // was 127 int isNullHomogeneous = (TYPEOF(nullValue) == LGLSXP || TYPEOF(nullValue) == REALSXP || TYPEOF(nullValue) == STRSXP || TYPEOF(nullValue) == INTSXP); int numStrings = 0; int numLogicals = 0; int numNumbers = 0; SEXP ans, names = NULL; PROTECT(ans = NEW_LIST(len)); nprotect++; int homogeneous = 0; int elType = NILSXP; while (ctr < len){ // i != json_end(n) i = json_at(n, ctr); if (i == NULL){ PROBLEM "Invalid JSON Node" ERROR; } json_char *node_name = json_name(i); char type = json_type(i); if(startType == 127) startType = type; SEXP el; switch(type) { case JSON_NULL: el = nullValue; /* R_NilValue; */ numNulls++; if(isNullHomogeneous) { homogeneous++; elType = setType(elType, TYPEOF(nullValue)); } else elType = TYPEOF(nullValue); break; case JSON_ARRAY: case JSON_NODE: el = processJSONNode(i, type, simplify, nullValue, simplifyWithNames, charEncoding, r_stringCall, str_fun_type); if(Rf_length(el) > 1) elType = VECSXP; else elType = setType(elType, TYPEOF(el)); break; case JSON_NUMBER: el = ScalarReal(json_as_float(i)); homogeneous++; elType = setType(elType, REALSXP); numNumbers++; break; case JSON_BOOL: el = ScalarLogical(json_as_bool(i)); elType = setType(elType, LGLSXP); numLogicals++; break; case JSON_STRING: { //XXX Garbage collection #if 0 //def JSON_UNICODE wchar_t *wtmp = json_as_string(i); char *tmp; int len = wcslen(wtmp); int size = sizeof(char) * (len * MB_LEN_MAX + 1); tmp = (char *)malloc(size); if (tmp == NULL) { PROBLEM "Cannot allocate memory" ERROR; } wcstombs(tmp, wtmp, size); #else char *tmp = json_as_string(i); // tmp = reEnc(tmp, CE_BYTES, CE_UTF8, 1); #endif if(r_stringCall != NULL && TYPEOF(r_stringCall) == EXTPTRSXP) { if(str_fun_type == SEXP_STR_ROUTINE) { SEXPStringRoutine fun; fun = (SEXPStringRoutine) R_ExternalPtrAddr(r_stringCall); el = fun(tmp, charEncoding); } else { char *tmp1; StringRoutine fun; fun = (StringRoutine) R_ExternalPtrAddr(r_stringCall); tmp1 = fun(tmp); if(tmp1 != tmp) json_free(tmp); tmp = tmp1; el = ScalarString(mkCharCE(tmp, charEncoding)); } } else { el = ScalarString(mkCharCE(tmp, charEncoding)); /* Call the R function if there is one. */ if(r_stringCall != NULL) { SETCAR(CDR(r_stringCall), el); el = Rf_eval(r_stringCall, R_GlobalEnv); } /* XXX compute with elType. */ } json_free(tmp); elType = setType(elType, /* If we have a class, not a primitive type */ Rf_length(getAttrib(el, Rf_install("class"))) ? LISTSXP : TYPEOF(el)); if(r_stringCall != NULL && str_fun_type != NATIVE_STR_ROUTINE) { switch(TYPEOF(el)) { case REALSXP: numNumbers++; break; case LGLSXP: numLogicals++; break; case STRSXP: numStrings++; break; } } else if(TYPEOF(el) == STRSXP) numStrings++; } break; default: PROBLEM "shouldn't be here" WARN; el = R_NilValue; break; } SET_VECTOR_ELT(ans, ctr, el); if(parentType == JSON_NODE || (node_name && node_name[0])) { if(names == NULL) { PROTECT(names = NEW_CHARACTER(len)); nprotect++; } if(node_name && node_name[0]) SET_STRING_ELT(names, ctr, mkChar(node_name)); } json_free(node_name); ctr++; } /* If we have an empty object, we try to make it into a form equivalent to emptyNamedList if it is a {}, or as an AsIs object in R if an empty array. */ if(len == 0 && (parentType == -1 || parentType == JSON_ARRAY || parentType == JSON_NODE)) { if(parentType == -1) parentType = startType; if(parentType == JSON_NODE) SET_NAMES(ans, NEW_CHARACTER(0)); else { SET_CLASS(ans, ScalarString(mkChar("AsIs"))); } } else if(simplifyWithNames || names == NULL || Rf_length(names) == 0) { int allSame = (numNumbers == len || numStrings == len || numLogicals == len) || ((TYPEOF(nullValue) == LGLSXP && LOGICAL(nullValue)[0] == NA_INTEGER) && ((numNumbers + numNulls) == len || (numStrings + numNulls) == len || (numLogicals + numNulls) == len)); homogeneous = allSame || ( (numNumbers + numStrings + numLogicals + numNulls) == len); if(simplify == NONE) { } else if(allSame && (numNumbers == len && (simplify & STRICT_NUMERIC)) || ((numLogicals == len) && (simplify & STRICT_LOGICAL)) || ( (numStrings == len) && (simplify & STRICT_CHARACTER))) { ans = makeVector(ans, len, elType, nullValue); } else if((simplify == ALL && homogeneous) || (simplify == STRICT && allSame)) { ans = makeVector(ans, len, elType, nullValue); } } if(names) SET_NAMES(ans, names); UNPROTECT(nprotect); return(ans); }
sqlite3 * GET_SQLITE_DB(SEXP rdb) { SQLiteConnection * con = (SQLiteConnection *) R_ExternalPtrAddr(rdb); return(con->drvConnection); }
SEXP euler_model_simulator (SEXP func, SEXP xstart, SEXP times, SEXP params, SEXP deltat, SEXP method, SEXP zeronames, SEXP tcovar, SEXP covar, SEXP args, SEXP gnsi) { int nprotect = 0; pompfunmode mode = undef; int nvars, npars, nreps, ntimes, nzeros, ncovars, covlen; int nstep = 0; double dt, dtt; SEXP X; SEXP ans, nm, fn, fcall = R_NilValue, rho = R_NilValue; SEXP Snames, Pnames, Cnames; SEXP cvec, tvec = R_NilValue; SEXP xvec = R_NilValue, pvec = R_NilValue, dtvec = R_NilValue; int *pidx = 0, *sidx = 0, *cidx = 0, *zidx = 0; pomp_onestep_sim *ff = NULL; int meth = INTEGER_VALUE(method); // meth: 0 = Euler, 1 = one-step, 2 = fixed step dtt = NUMERIC_VALUE(deltat); if (dtt <= 0) errorcall(R_NilValue,"'delta.t' should be a positive number"); { int *dim; dim = INTEGER(GET_DIM(xstart)); nvars = dim[0]; nreps = dim[1]; dim = INTEGER(GET_DIM(params)); npars = dim[0]; dim = INTEGER(GET_DIM(covar)); covlen = dim[0]; ncovars = dim[1]; ntimes = LENGTH(times); } PROTECT(Snames = GET_ROWNAMES(GET_DIMNAMES(xstart))); nprotect++; PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++; PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(covar))); nprotect++; // set up the covariate table struct lookup_table covariate_table = {covlen, ncovars, 0, REAL(tcovar), REAL(covar)}; // vector for interpolated covariates PROTECT(cvec = NEW_NUMERIC(ncovars)); nprotect++; SET_NAMES(cvec,Cnames); // indices of accumulator variables nzeros = LENGTH(zeronames); zidx = INTEGER(PROTECT(matchnames(Snames,zeronames,"state variables"))); nprotect++; // extract user function PROTECT(fn = pomp_fun_handler(func,gnsi,&mode)); nprotect++; // set up switch (mode) { case Rfun: // R function PROTECT(dtvec = NEW_NUMERIC(1)); nprotect++; PROTECT(tvec = NEW_NUMERIC(1)); nprotect++; PROTECT(xvec = NEW_NUMERIC(nvars)); nprotect++; PROTECT(pvec = NEW_NUMERIC(npars)); nprotect++; SET_NAMES(xvec,Snames); SET_NAMES(pvec,Pnames); // set up the function call PROTECT(fcall = LCONS(cvec,args)); nprotect++; SET_TAG(fcall,install("covars")); PROTECT(fcall = LCONS(dtvec,fcall)); nprotect++; SET_TAG(fcall,install("delta.t")); PROTECT(fcall = LCONS(pvec,fcall)); nprotect++; SET_TAG(fcall,install("params")); PROTECT(fcall = LCONS(tvec,fcall)); nprotect++; SET_TAG(fcall,install("t")); PROTECT(fcall = LCONS(xvec,fcall)); nprotect++; SET_TAG(fcall,install("x")); PROTECT(fcall = LCONS(fn,fcall)); nprotect++; // get function's environment PROTECT(rho = (CLOENV(fn))); nprotect++; break; case native: // native code // construct state, parameter, covariate indices sidx = INTEGER(PROTECT(matchnames(Snames,GET_SLOT(func,install("statenames")),"state variables"))); nprotect++; pidx = INTEGER(PROTECT(matchnames(Pnames,GET_SLOT(func,install("paramnames")),"parameters"))); nprotect++; cidx = INTEGER(PROTECT(matchnames(Cnames,GET_SLOT(func,install("covarnames")),"covariates"))); nprotect++; *((void **) (&ff)) = R_ExternalPtrAddr(fn); break; default: errorcall(R_NilValue,"unrecognized 'mode' %d",mode); // # nocov break; } // create array to hold results { int dim[3] = {nvars, nreps, ntimes}; PROTECT(X = makearray(3,dim)); nprotect++; setrownames(X,Snames,3); } // copy the start values into the result array memcpy(REAL(X),REAL(xstart),nvars*nreps*sizeof(double)); if (mode==1) { set_pomp_userdata(args); GetRNGstate(); } // now do computations { int first = 1; int use_names = 0; int *posn = 0; double *time = REAL(times); double *xs = REAL(X); double *xt = REAL(X)+nvars*nreps; double *cp = REAL(cvec); double *ps = REAL(params); double t = time[0]; double *pm, *xm; int i, j, k, step; for (step = 1; step < ntimes; step++, xs = xt, xt += nvars*nreps) { R_CheckUserInterrupt(); if (t > time[step]) { errorcall(R_NilValue,"'times' is not an increasing sequence"); } memcpy(xt,xs,nreps*nvars*sizeof(double)); // set accumulator variables to zero for (j = 0; j < nreps; j++) for (i = 0; i < nzeros; i++) xt[zidx[i]+nvars*j] = 0.0; switch (meth) { case 0: // Euler method dt = dtt; nstep = num_euler_steps(t,time[step],&dt); break; case 1: // one step dt = time[step]-t; nstep = (dt > 0) ? 1 : 0; break; case 2: // fixed step dt = dtt; nstep = num_map_steps(t,time[step],dt); break; default: errorcall(R_NilValue,"unrecognized 'method'"); // # nocov break; } for (k = 0; k < nstep; k++) { // loop over Euler steps // interpolate the covar functions for the covariates table_lookup(&covariate_table,t,cp); for (j = 0, pm = ps, xm = xt; j < nreps; j++, pm += npars, xm += nvars) { // loop over replicates switch (mode) { case Rfun: // R function { double *xp = REAL(xvec); double *pp = REAL(pvec); double *tp = REAL(tvec); double *dtp = REAL(dtvec); double *ap; *tp = t; *dtp = dt; memcpy(xp,xm,nvars*sizeof(double)); memcpy(pp,pm,npars*sizeof(double)); if (first) { PROTECT(ans = eval(fcall,rho)); nprotect++; // evaluate the call if (LENGTH(ans) != nvars) { errorcall(R_NilValue,"user 'step.fun' returns a vector of %d state variables but %d are expected: compare initial conditions?", LENGTH(ans),nvars); } PROTECT(nm = GET_NAMES(ans)); nprotect++; use_names = !isNull(nm); if (use_names) { posn = INTEGER(PROTECT(matchnames(Snames,nm,"state variables"))); nprotect++; } ap = REAL(AS_NUMERIC(ans)); first = 0; } else { ap = REAL(AS_NUMERIC(eval(fcall,rho))); } if (use_names) { for (i = 0; i < nvars; i++) xm[posn[i]] = ap[i]; } else { for (i = 0; i < nvars; i++) xm[i] = ap[i]; } } break; case native: // native code (*ff)(xm,pm,sidx,pidx,cidx,ncovars,cp,t,dt); break; default: errorcall(R_NilValue,"unrecognized 'mode' %d",mode); // # nocov break; } } t += dt; if ((meth == 0) && (k == nstep-2)) { // penultimate step dt = time[step]-t; t = time[step]-dt; } } } } if (mode==1) { PutRNGstate(); unset_pomp_userdata(); } UNPROTECT(nprotect); return X; }
SEXP imputeObservations(SEXP R_forest, SEXP registered_data, SEXP new_data) { hpdRFforest *forest = (hpdRFforest *) R_ExternalPtrAddr(R_forest); int temp_leaf_count, leaf_count=0, num_obs = length(VECTOR_ELT(new_data,0)); hpdRFnode **temp_leaves, **leaves = NULL; void **new_feature_observations = (void **) malloc(sizeof(void*)*length(new_data)); bool* new_int_data = (bool *) malloc(sizeof(bool)*length(new_data)); void **old_feature_observations = (void **) malloc(sizeof(void*)*length(registered_data)); bool* old_int_data = (bool *) malloc(sizeof(bool)*length(registered_data)); double *temp_weights, *weights; for(int col = 0; col < length(new_data); col++) { new_feature_observations[col] = RtoCArray<void *>(VECTOR_ELT(new_data,col)); new_int_data[col] = TYPEOF(VECTOR_ELT(new_data,col)) == INTSXP; } for(int col = 0; col < length(registered_data); col++) { old_feature_observations[col] = RtoCArray<void *>(VECTOR_ELT(registered_data,col)); old_int_data[col] = TYPEOF(VECTOR_ELT(registered_data,col)) == INTSXP; } for(int obs_index = 0; obs_index < num_obs; obs_index++) { for(int i = 0; i < forest->ntree; i++) { temp_leaf_count = 0; temp_leaves= treeTraverseObservation(forest->trees[i], new_data, forest->features_cardinality, obs_index, true, &temp_leaf_count, &temp_weights); hpdRFnode** temp = (hpdRFnode**) malloc(sizeof(hpdRFnode*)*(temp_leaf_count+leaf_count)); double* temp1 = (double *) malloc(sizeof(double)*(temp_leaf_count+leaf_count)); double total_tree_weight = 0; for(int j = 0; j < temp_leaf_count; j++) total_tree_weight += temp_leaves[j]->additional_info->num_obs; for(int j = 0; j < temp_leaf_count; j++) temp_weights[j] = temp_leaves[j]->additional_info->num_obs/ total_tree_weight; if(leaf_count != 0) { memcpy(temp,leaves,leaf_count*sizeof(hpdRFnode*)); memcpy(temp1,weights, leaf_count*sizeof(double)); } if(temp_leaf_count != 0) { memcpy(temp+leaf_count,temp_leaves, temp_leaf_count*sizeof(hpdRFnode*)); memcpy(temp1+leaf_count,temp_weights, temp_leaf_count*sizeof(double)); } free(temp_leaves); free(leaves); free(weights); free(temp_weights); leaves = temp; weights = temp1; leaf_count += temp_leaf_count; } for(int i = 0; i < leaf_count; i++) if(isnan(weights[i])) weights[i] = 0; double sample_id = forest->ntree*((double)rand()/(double)RAND_MAX); int i = 0; while(i < leaf_count) { if(sample_id >= weights[i]) sample_id -= weights[i]; else break; i++; } if(i < leaf_count && leaves[i]->additional_info->num_obs > 0) { int index = (int) (sample_id*leaves[i]->additional_info->num_obs); index = leaves[i]->additional_info->indices[index]-1; for(int col = 0; col < length(new_data); col++) { if(new_int_data[col] && old_int_data[col]) { ((int **) new_feature_observations)[col][obs_index] = ((int **) old_feature_observations)[col][index]; } if(new_int_data[col] && !old_int_data[col]) { ((int **) new_feature_observations)[col][obs_index] = ((double **) old_feature_observations)[col][index]; } if(!new_int_data[col] && old_int_data[col]) { ((double **) new_feature_observations)[col][obs_index] = ((int **) old_feature_observations)[col][index]; } if(!new_int_data[col] && !old_int_data[col]) { ((double **) new_feature_observations)[col][obs_index] = ((double **) old_feature_observations)[col][index]; } } } free(leaves); leaves = NULL; leaf_count = 0; free(weights); weights = NULL; } return R_NilValue; }
SEXP CombineSubMaps(BigMatrix *oneVox_allSubs, SEXP allVoxs_allSubs, index_type seed, double *pVoxs, index_type nvoxs, index_type nsubs) { //using namespace Rcpp; BMAccessorType outMat( *oneVox_allSubs ); if (nsubs != oneVox_allSubs->ncol()) Rf_error("nsubs must equal oneVox_allSubs->ncol"); if (nvoxs != oneVox_allSubs->nrow()) Rf_error("nsubs must equal oneVox_allSubs->nrow"); // loop through each subject's map index_type s = 0; index_type v = 0; index_type vv = 0; LDOUBLE x = 0; LDOUBLE delta = 0; LDOUBLE mean = 0; LDOUBLE M2 = 0; LDOUBLE stdev = 0; // CType *inCol; CType *outCol; LDOUBLE scaled_x; BigMatrix *allVoxs_oneSub; SEXP Rp; SEXP tmp; //RObject RallVoxs_oneSub; for (s=0; s < nsubs; ++s) { PROTECT(tmp = VECTOR_ELT(allVoxs_allSubs, s)); //RallVoxs_oneSub(tmp); //Rp = RallVoxs_oneSub.slot("address"); PROTECT(Rp = GET_SLOT(tmp, install("address"))); //tmp = allVoxs_allSubs[s]; //RObject RallVoxs_oneSub(tmp); //Rp = RallVoxs_oneSub.slot("address"); allVoxs_oneSub = reinterpret_cast<BigMatrix*>(R_ExternalPtrAddr(Rp)); UNPROTECT(2); BMAccessorType inMat( *allVoxs_oneSub ); // inCol = inMat[seed]; delta = mean = M2 = stdev = 0; for (v=0; v < nvoxs; ++v) { // todo: add checking for NaN...but shouldn't really have any! // maybe can also pass the exact list of voxs to loop through! // if (!ISNAN(pColumn[curj])) // NA_REAL vv = static_cast<index_type>(pVoxs[v]-1); x = static_cast<LDOUBLE>(inMat[vv][seed]); delta = x - mean; mean = mean + delta/static_cast<LDOUBLE>(v+1); M2 = M2 + delta*(x - mean); } stdev = sqrt(M2/(static_cast<LDOUBLE>(nvoxs-1))); //printf("mean: %f; stdev: %f\n", mean, stdev); outCol = outMat[s]; for (v=0; v < nvoxs; ++v) { vv = static_cast<index_type>(pVoxs[v]-1); scaled_x = (static_cast<LDOUBLE>(inMat[vv][seed])-mean)/stdev; outCol[v] = static_cast<CType>(scaled_x); } } return R_NilValue; }
SEXP do_init_state (SEXP object, SEXP params, SEXP t0, SEXP nsim, SEXP gnsi) { int nprotect = 0; SEXP Pnames, Snames; SEXP x = R_NilValue; int *dim; int npar, nrep, nvar, ns; int definit; int xdim[2]; const char *dimnms[2] = {"variable","rep"}; ns = *(INTEGER(AS_INTEGER(nsim))); PROTECT(params = as_matrix(params)); nprotect++; PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++; dim = INTEGER(GET_DIM(params)); npar = dim[0]; nrep = dim[1]; if (ns % nrep != 0) errorcall(R_NilValue,"in 'init.state': number of desired state-vectors 'nsim' is not a multiple of ncol('params')"); definit = *(INTEGER(GET_SLOT(object,install("default.init")))); if (definit) { // default initializer SEXP fcall, pat, repl, val, ivpnames, statenames; int *pidx, j, k; double *xp, *pp; PROTECT(pat = NEW_CHARACTER(1)); nprotect++; SET_STRING_ELT(pat,0,mkChar("\\.0$")); PROTECT(repl = NEW_CHARACTER(1)); nprotect++; SET_STRING_ELT(repl,0,mkChar("")); PROTECT(val = NEW_LOGICAL(1)); nprotect++; *(INTEGER(val)) = 1; // extract names of IVPs PROTECT(fcall = LCONS(val,R_NilValue)); nprotect++; SET_TAG(fcall,install("value")); PROTECT(fcall = LCONS(Pnames,fcall)); nprotect++; SET_TAG(fcall,install("x")); PROTECT(fcall = LCONS(pat,fcall)); nprotect++; SET_TAG(fcall,install("pattern")); PROTECT(fcall = LCONS(install("grep"),fcall)); nprotect++; PROTECT(ivpnames = eval(fcall,R_BaseEnv)); nprotect++; nvar = LENGTH(ivpnames); if (nvar < 1) { errorcall(R_NilValue,"in default 'initializer': there are no parameters with suffix '.0'. See '?pomp'."); } pidx = INTEGER(PROTECT(match(Pnames,ivpnames,0))); nprotect++; for (k = 0; k < nvar; k++) pidx[k]--; // construct names of state variables PROTECT(fcall = LCONS(ivpnames,R_NilValue)); nprotect++; SET_TAG(fcall,install("x")); PROTECT(fcall = LCONS(repl,fcall)); nprotect++; SET_TAG(fcall,install("replacement")); PROTECT(fcall = LCONS(pat,fcall)); nprotect++; SET_TAG(fcall,install("pattern")); PROTECT(fcall = LCONS(install("sub"),fcall)); nprotect++; PROTECT(statenames = eval(fcall,R_BaseEnv)); nprotect++; xdim[0] = nvar; xdim[1] = ns; PROTECT(x = makearray(2,xdim)); nprotect++; setrownames(x,statenames,2); fixdimnames(x,dimnms,2); for (j = 0, xp = REAL(x); j < ns; j++) { pp = REAL(params) + npar*(j%nrep); for (k = 0; k < nvar; k++, xp++) *xp = pp[pidx[k]]; } } else { // user-supplied initializer SEXP pompfun, fcall, fn, tcovar, covar, covars = R_NilValue; pompfunmode mode = undef; double *cp = NULL; // extract the initializer function and its environment PROTECT(pompfun = GET_SLOT(object,install("initializer"))); nprotect++; PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++; // extract covariates and interpolate PROTECT(tcovar = GET_SLOT(object,install("tcovar"))); nprotect++; if (LENGTH(tcovar) > 0) { // do table lookup PROTECT(covar = GET_SLOT(object,install("covar"))); nprotect++; PROTECT(covars = lookup_in_table(tcovar,covar,t0)); nprotect++; cp = REAL(covars); } // extract userdata PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++; switch (mode) { case Rfun: // use R function { SEXP par, rho, x1, x2; double *p, *pp, *xp, *xt; int j, *midx; // extract covariates and interpolate if (LENGTH(tcovar) > 0) { // add covars to call PROTECT(fcall = LCONS(covars,fcall)); nprotect++; SET_TAG(fcall,install("covars")); } // parameter vector PROTECT(par = NEW_NUMERIC(npar)); nprotect++; SET_NAMES(par,Pnames); pp = REAL(par); // finish constructing the call PROTECT(fcall = LCONS(t0,fcall)); nprotect++; SET_TAG(fcall,install("t0")); PROTECT(fcall = LCONS(par,fcall)); nprotect++; SET_TAG(fcall,install("params")); PROTECT(fcall = LCONS(fn,fcall)); nprotect++; // evaluation environment PROTECT(rho = (CLOENV(fn))); nprotect++; p = REAL(params); memcpy(pp,p,npar*sizeof(double)); // copy the parameters PROTECT(x1 = eval(fcall,rho)); nprotect++; // do the call PROTECT(Snames = GET_NAMES(x1)); nprotect++; if (!IS_NUMERIC(x1) || isNull(Snames)) { UNPROTECT(nprotect); errorcall(R_NilValue,"in 'init.state': user 'initializer' must return a named numeric vector"); } nvar = LENGTH(x1); xp = REAL(x1); midx = INTEGER(PROTECT(match(Pnames,Snames,0))); nprotect++; for (j = 0; j < nvar; j++) { if (midx[j]!=0) { UNPROTECT(nprotect); errorcall(R_NilValue,"in 'init.state': a state variable and a parameter share a single name: '%s'",CHARACTER_DATA(STRING_ELT(Snames,j))); } } xdim[0] = nvar; xdim[1] = ns; PROTECT(x = makearray(2,xdim)); nprotect++; setrownames(x,Snames,2); fixdimnames(x,dimnms,2); xt = REAL(x); memcpy(xt,xp,nvar*sizeof(double)); for (j = 1, xt += nvar; j < ns; j++, xt += nvar) { memcpy(pp,p+npar*(j%nrep),npar*sizeof(double)); PROTECT(x2 = eval(fcall,rho)); xp = REAL(x2); if (LENGTH(x2)!=nvar) errorcall(R_NilValue,"in 'init.state': user initializer returns vectors of non-uniform length"); memcpy(xt,xp,nvar*sizeof(double)); UNPROTECT(1); } } break; case native: // use native routine { SEXP Cnames; int *sidx, *pidx, *cidx; double *xt, *ps, time; pomp_initializer *ff = NULL; int j; PROTECT(Snames = GET_SLOT(pompfun,install("statenames"))); nprotect++; PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(GET_SLOT(object,install("covar"))))); nprotect++; // construct state, parameter, covariate, observable indices sidx = INTEGER(PROTECT(name_index(Snames,pompfun,"statenames","state variables"))); nprotect++; pidx = INTEGER(PROTECT(name_index(Pnames,pompfun,"paramnames","parameters"))); nprotect++; cidx = INTEGER(PROTECT(name_index(Cnames,pompfun,"covarnames","covariates"))); nprotect++; // address of native routine *((void **) (&ff)) = R_ExternalPtrAddr(fn); nvar = LENGTH(Snames); xdim[0] = nvar; xdim[1] = ns; PROTECT(x = makearray(2,xdim)); nprotect++; setrownames(x,Snames,2); fixdimnames(x,dimnms,2); set_pomp_userdata(fcall); GetRNGstate(); time = *(REAL(t0)); // loop over replicates for (j = 0, xt = REAL(x), ps = REAL(params); j < ns; j++, xt += nvar) (*ff)(xt,ps+npar*(j%nrep),time,sidx,pidx,cidx,cp); PutRNGstate(); unset_pomp_userdata(); } break; default: errorcall(R_NilValue,"in 'init.state': unrecognized 'mode'"); // # nocov break; } } UNPROTECT(nprotect); return x; }
SEXP R_ffi_call(SEXP r_cif, SEXP r_args, SEXP r_sym, SEXP r_sexpType) { void *sym = R_ExternalPtrAddr(r_sym); void **retVal = NULL; void **args = NULL; unsigned int nargs, i; SEXP r_ans = R_NilValue; int isVoid; ffi_cif *cif; if(!sym) { PROBLEM "NULL value passed for routine to invoke" ERROR; } cif = (ffi_cif *) R_ExternalPtrAddr(r_cif); if(!cif) { PROBLEM "NULL value passed for call interface pointer" ERROR; } nargs = Rf_length(r_args); if(nargs != cif->nargs) { PROBLEM "incorrect number of arguments in ffi call: %d, should be %d", (int) nargs, (int) cif->nargs ERROR; } if(nargs > 0) { void **indirect; args = (void **) R_alloc(sizeof(void *), nargs); indirect = (void **) R_alloc(sizeof(void *), nargs); if(!args || !indirect) { PROBLEM "cannot allocate space for vector of arguments in ffi call" ERROR; } for(i = 0; i < nargs ; i++) { void *tmp; tmp = convertToNative(args + i, VECTOR_ELT(r_args, i), cif->arg_types[i]); if(cif->arg_types[i] == &ffi_type_pointer) { args[i] = indirect + i; indirect[i] = tmp; } else args[i] = tmp; } } isVoid = (cif->rtype == &ffi_type_void || cif->rtype->type == ffi_type_void.type); if(!isVoid) retVal = (void **) R_alloc(sizeof(void *), cif->rtype->size); ffi_call(cif, sym, retVal, args); /* if(status != FFI_OK) { PROBLEM "ffi call failed: %s", status == FFI_BAD_TYPEDEF ? "bad typedef" : "bad ABI" ERROR; } */ if(!isVoid) { if(cif->rtype == R_ExternalPtrAddr(r_sexpType)) return(*((SEXP *) retVal)); r_ans = convertFromNative(retVal, cif->rtype); } return(r_ans); }
SEXP R_tarExtract(SEXP r_filename, SEXP r_filenames, SEXP r_fun, SEXP r_data, SEXP r_workBuf) { TarExtractCallbackFun callback = R_tarCollectContents; RTarCallInfo rcb; Rboolean doRcallback = (TYPEOF(r_fun) == CLOSXP); void *data; gzFile *f = NULL; int numFiles = LENGTH(r_filenames), i; const char **argv; int argc = numFiles + 1; if(TYPEOF(r_filename) == STRSXP) { const char *filename; filename = CHAR(STRING_ELT(r_filename, 0)); f = gzopen(filename, "rb"); if(!f) { PROBLEM "Can't open file %s", filename ERROR; } } if(doRcallback) { SEXP p; rcb.rawData = r_workBuf; rcb.numProtects = 0; rcb.offset = 0; PROTECT(rcb.e = p = allocVector( LANGSXP, 3)); SETCAR(p, r_fun); callback = R_tarCollectContents; data = (void *) &rcb; } else { data = (void *) r_data; callback = (TarExtractCallbackFun) R_ExternalPtrAddr(r_fun); } argv = (char **) S_alloc(numFiles + 1, sizeof(char *)); argv[0] = "R"; for(i = 1; i < numFiles + 1; i++) argv[i] = CHAR(STRING_ELT(r_filenames, i-1)); if(TYPEOF(r_filename) == STRSXP) tar(f, TGZ_EXTRACT, numFiles + 1, argc, argv, (TarCallbackFun) callback, (void *) data); else { DataSource src; R_rawStream stream; stream.data = RAW(r_filename); stream.len = LENGTH(r_filename); stream.pos = 0; src.data = &stream; src.throwError = rawError; src.read = rawRead; funTar(&src, TGZ_EXTRACT, numFiles + 1, argc, argv, (TarCallbackFun) callback, (void *) data); } if(doRcallback) UNPROTECT(1); if(rcb.numProtects > 0) UNPROTECT(rcb.numProtects); if (f && gzclose(f) != Z_OK) error("failed gzclose"); return(R_NilValue); }
SEXP derefPtr(SEXP SmultiPtr) { void **doublePtr = static_cast<void **>(R_ExternalPtrAddr(SmultiPtr)); return(R_MakeExternalPtr( static_cast<void *>(*doublePtr), R_NilValue, R_NilValue) ); }
static void mongoFinalizer(SEXP ptr) { if (!R_ExternalPtrAddr(ptr)) return; mongo_destroy((mongo*)R_ExternalPtrAddr(ptr)); R_ClearExternalPtr(ptr); }
/* This function updates the forest by splitting the nodes specified @param R_observations - observations of feature vectors @param R_responses - observations of response variable @param R_forest - forest @param R_active_nodes - active nodes to update @param R_splits_info - best splits for all nodes @param R_max_depth - the depth for which to stop growing trees @return - count of observations in all leaf nodes */ SEXP updateNodes(SEXP R_observations, SEXP R_responses, SEXP R_forest, SEXP R_active_nodes, SEXP R_splits_info, SEXP R_max_depth) { hpdRFforest *forest = (hpdRFforest *) R_ExternalPtrAddr(R_forest); int* features_categorical = forest-> features_cardinality; int* bin_num = forest->bin_num; int features_num = forest->features_num; int leaf_nodes = forest->nleaves - length(R_active_nodes) + 2*INTEGER(getAttrib(R_splits_info,install("total_completed")))[0]; hpdRFnode **new_leaves = (hpdRFnode**)malloc(sizeof(hpdRFnode*)*leaf_nodes); SEXP R_node_counts; PROTECT(R_node_counts = allocVector(INTSXP,leaf_nodes)); int *node_counts = INTEGER(R_node_counts); int max_depth = INTEGER(R_max_depth)[0]; leaf_nodes = 0; int index = 0; for(int i = 0; i < forest->nleaves;i++) { hpdRFnode* node_curr = forest->leaf_nodes[i]; int next_active_node = index < length(R_active_nodes) ? INTEGER(R_active_nodes)[index]-1: -1; if(i == next_active_node) { if(INTEGER(VECTOR_ELT(VECTOR_ELT(R_splits_info,index),0))[0]==1) { int active_node = INTEGER(R_active_nodes)[index]-1; node_curr = forest->leaf_nodes[active_node]; int* left_child_node_observations; int* right_child_node_observations; double* left_child_weights, *right_child_weights; int left_child_num_obs, right_child_num_obs; int* node_observations = node_curr->additional_info->indices; double* node_weights = node_curr->additional_info->weights; int node_observations_num = node_curr->additional_info->num_obs; int node_split_variable = INTEGER(VECTOR_ELT(VECTOR_ELT(R_splits_info,index),1))[0]-1; SEXP node_split_criteria = VECTOR_ELT(VECTOR_ELT(R_splits_info,index),2); updateNode(VECTOR_ELT(R_observations,node_split_variable), node_split_criteria, node_observations, node_observations_num, &left_child_node_observations, &right_child_node_observations, features_categorical[node_split_variable] != NA_INTEGER, bin_num[node_split_variable], node_weights, &left_child_weights, &right_child_weights, &left_child_num_obs, &right_child_num_obs); hpdRFnode *node_left_child = createChildNode(node_curr, FALSE, left_child_node_observations, left_child_weights, left_child_num_obs,features_num); hpdRFnode *node_right_child = createChildNode(node_curr, FALSE, right_child_node_observations, right_child_weights, right_child_num_obs,features_num); node_curr->left = node_left_child; node_curr->right = node_right_child; if(node_left_child->additional_info->depth <= max_depth) { node_left_child->additional_info->leafID = leaf_nodes+1; node_counts[leaf_nodes] = node_left_child->additional_info->num_obs; new_leaves[leaf_nodes++] = node_left_child; } if(node_right_child->additional_info->depth <= max_depth) { node_right_child->additional_info->leafID = leaf_nodes+1; node_counts[leaf_nodes] = node_right_child->additional_info->num_obs; new_leaves[leaf_nodes++] = node_right_child; } } cleanSingleNode(node_curr); index ++; } else if(i != next_active_node && node_curr->additional_info->depth <= max_depth) { node_curr->additional_info->leafID = leaf_nodes+1; node_counts[leaf_nodes] = node_curr->additional_info->num_obs; new_leaves[leaf_nodes++] = node_curr; } } free(forest->leaf_nodes); forest->nleaves = leaf_nodes; forest->leaf_nodes = new_leaves; SETLENGTH(R_node_counts,leaf_nodes); UNPROTECT(1); return R_node_counts; }
/** * Compute the approximation to the deviance using adaptive * Gauss-Hermite quadrature (AGQ). When nAGQ == 1 this is the Laplace * approximation. * * @param pars pointer to a numeric vector of parameters * @param GSp pointer to a GlmerStruct object * @param nAGQp pointer to a scalar integer representing the number of * points in AGQ to use * * @return the approximation to the deviance as computed using AGQ */ SEXP glmer_devAGQ(SEXP pars, SEXP GSp, SEXP nAGQp) { GlmerStruct GS = (GlmerStruct) R_ExternalPtrAddr(GSp); SEXP Omega = GET_SLOT(GS->mer, lme4_OmegaSym), bVar = GET_SLOT(GS->mer, lme4_bVarSym); int i, j, k, nAGQ = asInteger(nAGQp); int n2 = (nAGQ + 1)/2, *Gp = INTEGER(GET_SLOT(GS->mer, lme4_GpSym)), *nc = INTEGER(GET_SLOT(GS->mer, lme4_ncSym)); double *f0, LaplaceDev = 0, AGQadjst = 0, *bhat = REAL(GET_SLOT(GS->mer, lme4_ranefSym)); if (!isReal(pars) || LENGTH(pars) != GS->npar) error(_("`%s' must be a numeric vector of length %d"), "pars", GS->npar); if (GS->nf > 1 && nAGQ > 1) { warning(_("AGQ not available for multiple grouping factors - using Laplace")); nAGQ = 1; } if (!internal_bhat(GS, REAL(pars), REAL(pars) + (GS->p))) return ScalarReal(DBL_MAX); for (i = 0; i < GS->nf; i++) { int nci = nc[i]; int ncip1 = nci + 1, ncisqr = nci * nci, nlev = (Gp[i + 1] - Gp[i])/nci; double *omgf = REAL(GET_SLOT(M_dpoMatrix_chol(VECTOR_ELT(Omega, i)), lme4_xSym)), *bVi = Memcpy(Calloc(ncisqr * nlev, double), REAL(VECTOR_ELT(bVar, i)), ncisqr * nlev); for (j = 0; j < nci; j++) { /* nlev * logDet(Omega_i) */ LaplaceDev += 2 * nlev * log(omgf[j * ncip1]); } for (k = 0; k < nlev; k++) { double *bVik = bVi + k * ncisqr; F77_CALL(dpotrf)("U", &nci, bVik, &nci, &j); if (j) error(_("Leading %d minor of bVar[[%d]][,,%d] not positive definite"), j, i + 1, k + 1); for (j = 0; j < nci; j++) LaplaceDev -= 2 * log(bVik[j * ncip1]); } f0 = Calloc(nlev, double); rel_dev_1(GS, bhat, nlev, nci, i, (double *) NULL, omgf, bVi, f0); for (k = 0; k < nlev; k++) LaplaceDev += f0[k]; if (nAGQ > 1) { double *fx = Calloc(nlev, double), *rellik = Calloc(nlev, double), *delb = Calloc(nci, double); if (nci > 1) error(_("code not yet written")); AZERO(rellik, nlev); /* zero accumulator */ for (k = 0; k < n2; k++) { delb[0] = GHQ_x[nAGQ][k]; if (delb[0]) { rel_dev_1(GS, bhat, nlev, nci, i, delb, omgf, bVi, fx); for (j = 0; j < nlev; j++) { rellik[j] += GHQ_w[nAGQ][k] * exp(-(fx[j] - f0[j])/2); } delb[0] *= -1; rel_dev_1(GS, bhat, nlev, nci, i, delb, omgf, bVi, fx); for (j = 0; j < nlev; j++) { rellik[j] += GHQ_w[nAGQ][k] * exp(-(fx[j] - f0[j])/2); } } else { for (j = 0; j < nlev; j++) rellik[j] += GHQ_w[nAGQ][k]; } } for (j = 0; j < nlev; j++) AGQadjst -= 2 * log(rellik[j]); Free(fx); Free(rellik); } Free(f0); Free(bVi); }
void * convertToNative(void **val, SEXP r_val, ffi_type *type) /* need something about copying, to control memory recollection*/ { void *ans = NULL; if(type == &ffi_type_sexp) { SEXP *p = (SEXP *) R_alloc(sizeof(SEXP), 1); *p = r_val; ans = p; } else if(type == &ffi_type_pointer) { SEXPREC_ALIGN *p; if(r_val == R_NilValue) ans = NULL; else if(IS_S4_OBJECT(r_val) && R_is(r_val, "AddressOf")) { ans = getAddressOfExtPtr(GET_SLOT(r_val, Rf_install("ref"))); } else if(IS_S4_OBJECT(r_val) && R_is(r_val, "RNativeReference")) { ans = R_ExternalPtrAddr(GET_SLOT(r_val, Rf_install("ref"))); } else { /* Should be looking at the element type, not at r_val. */ switch(TYPEOF(r_val)) { case INTSXP: case LGLSXP: { p = ((SEXPREC_ALIGN *) r_val) + 1; ans = p; /* ans = &r_val + sizeof(SEXPREC_ALIGN*); */ /* INTEGER(r_val); */ } break; case REALSXP: p = ((SEXPREC_ALIGN *) r_val) + 1; ans = p; /* REAL(r_val); */ break; case STRSXP: /*XXX What should happen is not clear here. The char ** or the single */ ans = Rf_length(r_val) ? CHAR(STRING_ELT(r_val, 0)) : NULL; break; case EXTPTRSXP: ans = R_ExternalPtrAddr(r_val); break; case CLOSXP: ans = r_val; break; case RAWSXP: ans = RAW(r_val); break; default: PROBLEM "unhandled conversion from R type (%d) to native FFI type", TYPEOF(r_val) ERROR; break; } } } else { if(type->type == FFI_TYPE_STRUCT) { ans = convertRToStruct(r_val, type); } else if(type == &ffi_type_string) { const char * * tmp; tmp = (const char * * ) R_alloc(sizeof(char *), 1); if(r_val == R_NilValue) *tmp = NULL; else *tmp = CHAR(STRING_ELT(r_val, 0)); ans = tmp; } else if(type == &ffi_type_double) { ans = REAL(r_val); } else if(type == &ffi_type_float) { /* We allocate a float, populate it with the value and return a pointer to that new float. It is released when we return from the .Call(). */ float *tmp = (float *) R_alloc(sizeof(float), 1); *tmp = REAL(r_val)[0]; ans = tmp; } else if(type == &ffi_type_sint32) { #if 1 /*experiment*/ if(IS_S4_OBJECT(r_val) && R_is(r_val, "RNativeReference")) { void **tmp = (void **) malloc(sizeof(void *)); *tmp = R_ExternalPtrAddr(GET_SLOT(r_val, Rf_install("ref"))) ; return(tmp); } #endif if(TYPEOF(r_val) == INTSXP) { ans = INTEGER(r_val); } else if(IS_S4_OBJECT(r_val) && R_is(r_val, "RNativeReference")) { ans = (int *) R_ExternalPtrAddr(GET_SLOT(r_val, Rf_install("ref"))); } else { int *i = (int *) R_alloc(sizeof(int), 1); i[0] = INTEGER(coerceVector(r_val, INTSXP))[0]; ans = i; } } else if(type == &ffi_type_sint16) { short *s = (short *) R_alloc(1, 16); *s = INTEGER(coerceVector(r_val, INTSXP))[0]; ans = s; } else if(type == &ffi_type_uint32) { unsigned int *tmp = (unsigned int *) R_alloc(sizeof(unsigned int), 1); *tmp = TYPEOF(r_val) == REALSXP ? REAL(r_val)[0] : INTEGER(r_val)[0]; ans = tmp; } else if(type == &ffi_type_uint16) { unsigned short *tmp = (unsigned short *) R_alloc(sizeof(unsigned short), 1); *tmp = TYPEOF(r_val) == REALSXP ? REAL(r_val)[0] : INTEGER(r_val)[0]; ans = tmp; } } /* Rprintf("convert->native: %p\n", ans); */ return(ans); }
SEXP do_dprior (SEXP object, SEXP params, SEXP log, SEXP gnsi) { int nprotect = 0; pompfunmode mode = undef; int npars, nreps; SEXP Pnames, F, fn, fcall; SEXP pompfun; int *dim; PROTECT(params = as_matrix(params)); nprotect++; dim = INTEGER(GET_DIM(params)); npars = dim[0]; nreps = dim[1]; PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++; // extract the user-defined function PROTECT(pompfun = GET_SLOT(object,install("dprior"))); nprotect++; PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++; // extract 'userdata' as pairlist PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++; // to store results PROTECT(F = NEW_NUMERIC(nreps)); nprotect++; // first do setup switch (mode) { case Rfun: // use R function { SEXP pvec, rho; double *pp, *ps, *pt; int j; // temporary storage PROTECT(pvec = NEW_NUMERIC(npars)); nprotect++; SET_NAMES(pvec,Pnames); // set up the function call PROTECT(fcall = LCONS(AS_LOGICAL(log),fcall)); nprotect++; SET_TAG(fcall,install("log")); PROTECT(fcall = LCONS(pvec,fcall)); nprotect++; SET_TAG(fcall,install("params")); PROTECT(fcall = LCONS(fn,fcall)); nprotect++; // get the function's environment PROTECT(rho = (CLOENV(fn))); nprotect++; pp = REAL(pvec); for (j = 0, ps = REAL(params), pt = REAL(F); j < nreps; j++, ps += npars, pt++) { memcpy(pp,ps,npars*sizeof(double)); *pt = *(REAL(AS_NUMERIC(eval(fcall,rho)))); } } break; case native: // use native routine { int give_log, *pidx = 0; pomp_dprior *ff = NULL; double *ps, *pt; int j; // construct state, parameter, covariate, observable indices pidx = INTEGER(PROTECT(name_index(Pnames,pompfun,"paramnames"))); nprotect++; // address of native routine ff = (pomp_dprior *) R_ExternalPtrAddr(fn); give_log = *(INTEGER(AS_INTEGER(log))); R_CheckUserInterrupt(); // check for user interrupt set_pomp_userdata(fcall); // loop over replicates for (j = 0, pt = REAL(F), ps = REAL(params); j < nreps; j++, ps += npars, pt++) (*ff)(pt,ps,give_log,pidx); unset_pomp_userdata(); } break; default: error("unrecognized 'mode' slot in 'dprior'"); break; } UNPROTECT(nprotect); return F; }
SEXP R_tarInfo(SEXP r_filename, SEXP r_fun, SEXP r_data) { gzFile *f = NULL; const char *filename; char *argv[] = {"R"}; TarCallbackFun callback = R_tarInfo_callback; RTarCallInfo rcb; Rboolean doRcallback = (TYPEOF(r_fun) == CLOSXP); void *data; if(TYPEOF(r_filename) == STRSXP) { filename = CHAR(STRING_ELT(r_filename, 0)); f = gzopen(filename, "rb"); if(!f) { PROBLEM "Can't open file %s", filename ERROR; } } if(doRcallback) { SEXP p; PROTECT(rcb.e = p = allocVector(LANGSXP, 6)); SETCAR(p, r_fun); p = CDR(p); SETCAR(p, allocVector(STRSXP, 1)); p = CDR(p); /* file */ SETCAR(p, mkString("a")); p = CDR(p); /* type flag */ SETCAR(p, allocVector(REALSXP, 1)); p = CDR(p); /* time */ SETCAR(p, allocVector(INTSXP, 1)); p = CDR(p); /* remaining */ SETCAR(p, allocVector(INTSXP, 1)); p = CDR(p); /* counter */ data = (void *) &rcb; } else { data = (void *) r_data; callback = (TarCallbackFun) R_ExternalPtrAddr(r_fun); } if(f) { tar(f, TGZ_LIST, 1, sizeof(argv)/sizeof(argv[0]), argv, callback, (void *) data); } else { DataSource src; R_rawStream stream; stream.data = RAW(r_filename); stream.len = LENGTH(r_filename); stream.pos = 0; src.data = &stream; src.throwError = rawError; src.read = rawRead; funTar(&src, TGZ_LIST, 1, sizeof(argv)/sizeof(argv[0]), argv, callback, (void *) data); } if(doRcallback) UNPROTECT(1); if (f && gzclose(f) != Z_OK) error("failed gzclose"); return(R_NilValue); }
static void RTcl_dec_refcount(SEXP R_tclobj) { Tcl_DecrRefCount((Tcl_Obj *) R_ExternalPtrAddr(R_tclobj)); }
SEXP getFillBandwith(SEXP sp){ if(R_ExternalPtrTag(sp) != install("covafillPointer")) Rf_error("The pointer must be to a covafill object"); covafill<double>* ptr=(covafill<double>*)R_ExternalPtrAddr(sp); return asSEXP(ptr->h); }
/* Wrapper to fits_get_img_size */ SEXP cfitsio_get_img_size (SEXP fits_object) { fits_file_t * fits = R_ExternalPtrAddr (fits_object); if (NULL != fits && NULL != fits->cfitsio_ptr) { int naxis; int i; LONGLONG * axes_dimensions; SEXP result; int verybig_flag; /* First retrieve the number of dimensions */ fits_get_img_dim (fits->cfitsio_ptr, &naxis, &(fits->status)); if (fits->status != 0) return ScalarInteger (-1); axes_dimensions = (LONGLONG *) R_alloc (sizeof (LONGLONG), naxis); /* Now get the size for each dimension */ fits_get_img_sizell (fits->cfitsio_ptr, naxis, &axes_dimensions[0], &(fits->status)); /* Check that the sizes are small enough to be contained in a * integer or not */ verybig_flag = 0; if (sizeof (LONGLONG) > sizeof (int)) { for (i = 0; i < naxis; ++i) { if (axes_dimensions[i] > (long) SINT_MAX) verybig_flag = 1; } } /* Build a R array and initialize it with the numbers returned * by fits_get_img_size */ if (verybig_flag) { PROTECT(result = allocVector (INTSXP, naxis)); for (i = 0; i < naxis; ++i) INTEGER(result)[i] = axes_dimensions[i]; } else { PROTECT(result = allocVector (REALSXP, naxis)); for (i = 0; i < naxis; ++i) REAL(result)[i] = axes_dimensions[i]; } UNPROTECT(1); return result; } else return R_NilValue; }
/* {{{ rberkeley_db_stat */ SEXP rberkeley_db_stat (SEXP _dbp, SEXP _txnid, SEXP _flags) { DB *dbp; DB_TXN *txnid; DBTYPE type; u_int32_t flags; dbp = R_ExternalPtrAddr(_dbp); if(R_ExternalPtrTag(_dbp) != RBerkeley_DB || dbp == NULL) error("invalid 'db' handle"); if(!isNull(_txnid)) { txnid = R_ExternalPtrAddr(_txnid); } else txnid = NULL; flags = (u_int32_t)INTEGER(_flags)[0]; dbp->get_type(dbp, &type); /* DBTYPE to know structure returned */ SEXP DBstat=NULL, DBstatnames=NULL; DB_HASH_STAT *hash=NULL; DB_BTREE_STAT *bt=NULL; DB_QUEUE_STAT *qs=NULL; switch(type) { case DB_HASH: dbp->stat(dbp, txnid, &hash, flags); PROTECT(DBstat = allocVector(VECSXP,16)); PROTECT(DBstatnames = allocVector(STRSXP,16)); SET_VECTOR_ELT(DBstat, 0, ScalarInteger(hash->hash_magic)); SET_STRING_ELT(DBstatnames, 0, mkChar("hash_magic")); SET_VECTOR_ELT(DBstat, 1, ScalarInteger(hash->hash_version)); SET_STRING_ELT(DBstatnames, 1, mkChar("hash_version")); SET_VECTOR_ELT(DBstat, 2, ScalarInteger(hash->hash_nkeys)); SET_STRING_ELT(DBstatnames, 2, mkChar("hash_nkeys")); SET_VECTOR_ELT(DBstat, 3, ScalarInteger(hash->hash_ndata)); SET_STRING_ELT(DBstatnames, 3, mkChar("hash_ndata")); SET_VECTOR_ELT(DBstat, 4, ScalarInteger(hash->hash_pagecnt)); SET_STRING_ELT(DBstatnames, 4, mkChar("hash_pagecnt")); SET_VECTOR_ELT(DBstat, 5, ScalarInteger(hash->hash_pagesize)); SET_STRING_ELT(DBstatnames, 5, mkChar("hash_pagesize")); SET_VECTOR_ELT(DBstat, 6, ScalarInteger(hash->hash_ffactor)); SET_STRING_ELT(DBstatnames, 6, mkChar("hash_ffactor")); SET_VECTOR_ELT(DBstat, 7, ScalarInteger(hash->hash_buckets)); SET_STRING_ELT(DBstatnames, 7, mkChar("hash_buckets")); SET_VECTOR_ELT(DBstat, 8, ScalarInteger(hash->hash_free)); SET_STRING_ELT(DBstatnames, 8, mkChar("hash_free")); SET_VECTOR_ELT(DBstat, 9, ScalarInteger(hash->hash_bfree)); SET_STRING_ELT(DBstatnames, 9, mkChar("hash_bfree")); SET_VECTOR_ELT(DBstat, 10, ScalarInteger(hash->hash_bigpages)); SET_STRING_ELT(DBstatnames, 10, mkChar("hash_bigpages")); SET_VECTOR_ELT(DBstat, 11, ScalarInteger(hash->hash_big_bfree)); SET_STRING_ELT(DBstatnames, 11, mkChar("hash_big_bfree")); SET_VECTOR_ELT(DBstat, 12, ScalarInteger(hash->hash_overflows)); SET_STRING_ELT(DBstatnames, 12, mkChar("hash_overflows")); SET_VECTOR_ELT(DBstat, 13, ScalarInteger(hash->hash_ovfl_free)); SET_STRING_ELT(DBstatnames, 13, mkChar("hash_ovfl_free")); SET_VECTOR_ELT(DBstat, 14, ScalarInteger(hash->hash_dup)); SET_STRING_ELT(DBstatnames, 14, mkChar("hash_dup")); SET_VECTOR_ELT(DBstat, 15, ScalarInteger(hash->hash_dup_free)); SET_STRING_ELT(DBstatnames, 15, mkChar("hash_dup_free")); case DB_BTREE: case DB_RECNO: dbp->stat(dbp, txnid, &bt, flags); PROTECT(DBstat = allocVector(VECSXP,19)); PROTECT(DBstatnames = allocVector(STRSXP,19)); SET_VECTOR_ELT(DBstat, 0, ScalarInteger(bt->bt_magic)); SET_STRING_ELT(DBstatnames, 0, mkChar("bt_magic")); SET_VECTOR_ELT(DBstat, 1, ScalarInteger(bt->bt_version)); SET_STRING_ELT(DBstatnames, 1, mkChar("bt_version")); SET_VECTOR_ELT(DBstat, 2, ScalarInteger(bt->bt_nkeys)); SET_STRING_ELT(DBstatnames, 2, mkChar("bt_nkeys")); SET_VECTOR_ELT(DBstat, 3, ScalarInteger(bt->bt_ndata)); SET_STRING_ELT(DBstatnames, 3, mkChar("bt_ndata")); SET_VECTOR_ELT(DBstat, 4, ScalarInteger(bt->bt_pagecnt)); SET_STRING_ELT(DBstatnames, 4, mkChar("bt_pagecnt")); SET_VECTOR_ELT(DBstat, 5, ScalarInteger(bt->bt_minkey)); SET_STRING_ELT(DBstatnames, 5, mkChar("bt_minkey")); SET_VECTOR_ELT(DBstat, 6, ScalarInteger(bt->bt_re_len)); SET_STRING_ELT(DBstatnames, 6, mkChar("bt_re_len")); SET_VECTOR_ELT(DBstat, 7, ScalarInteger(bt->bt_re_pad)); SET_STRING_ELT(DBstatnames, 7, mkChar("bt_re_pad")); SET_VECTOR_ELT(DBstat, 8, ScalarInteger(bt->bt_levels)); SET_STRING_ELT(DBstatnames, 8, mkChar("bt_levels")); SET_VECTOR_ELT(DBstat, 9, ScalarInteger(bt->bt_int_pg)); SET_STRING_ELT(DBstatnames, 9, mkChar("bt_int_pg")); SET_VECTOR_ELT(DBstat, 10, ScalarInteger(bt->bt_leaf_pg)); SET_STRING_ELT(DBstatnames, 10, mkChar("bt_leaf_pg")); SET_VECTOR_ELT(DBstat, 11, ScalarInteger(bt->bt_dup_pg)); SET_STRING_ELT(DBstatnames, 11, mkChar("bt_dup_pg")); SET_VECTOR_ELT(DBstat, 12, ScalarInteger(bt->bt_over_pg)); SET_STRING_ELT(DBstatnames, 12, mkChar("bt_over_pg")); SET_VECTOR_ELT(DBstat, 13, ScalarInteger(bt->bt_empty_pg)); SET_STRING_ELT(DBstatnames, 13, mkChar("bt_empty_pg")); SET_VECTOR_ELT(DBstat, 14, ScalarInteger(bt->bt_free)); SET_STRING_ELT(DBstatnames, 14, mkChar("bt_free")); SET_VECTOR_ELT(DBstat, 15, ScalarInteger(bt->bt_int_pgfree)); SET_STRING_ELT(DBstatnames, 15, mkChar("bt_int_pgfree")); SET_VECTOR_ELT(DBstat, 16, ScalarInteger(bt->bt_leaf_pgfree)); SET_STRING_ELT(DBstatnames, 16, mkChar("bt_leaf_pgfree")); SET_VECTOR_ELT(DBstat, 17, ScalarInteger(bt->bt_dup_pgfree)); SET_STRING_ELT(DBstatnames, 17, mkChar("bt_dup_pgfree")); SET_VECTOR_ELT(DBstat, 18, ScalarInteger(bt->bt_over_pgfree)); SET_STRING_ELT(DBstatnames, 18, mkChar("bt_over_pgfree")); break; case DB_QUEUE: dbp->stat(dbp, txnid, &qs, flags); PROTECT(DBstat = allocVector(VECSXP,12)); PROTECT(DBstatnames = allocVector(STRSXP,12)); SET_VECTOR_ELT(DBstat, 0, ScalarInteger(qs->qs_magic)); SET_STRING_ELT(DBstatnames, 0, mkChar("qs_magic")); SET_VECTOR_ELT(DBstat, 1, ScalarInteger(qs->qs_version)); SET_STRING_ELT(DBstatnames, 1, mkChar("qs_version")); SET_VECTOR_ELT(DBstat, 2, ScalarInteger(qs->qs_nkeys)); SET_STRING_ELT(DBstatnames, 2, mkChar("qs_nkeys")); SET_VECTOR_ELT(DBstat, 3, ScalarInteger(qs->qs_ndata)); SET_STRING_ELT(DBstatnames, 3, mkChar("qs_ndata")); SET_VECTOR_ELT(DBstat, 4, ScalarInteger(qs->qs_pagesize)); SET_STRING_ELT(DBstatnames, 4, mkChar("qs_pagesize")); SET_VECTOR_ELT(DBstat, 5, ScalarInteger(qs->qs_extentsize)); SET_STRING_ELT(DBstatnames, 5, mkChar("qs_extentsize")); SET_VECTOR_ELT(DBstat, 6, ScalarInteger(qs->qs_pages)); SET_STRING_ELT(DBstatnames, 6, mkChar("qs_pages")); SET_VECTOR_ELT(DBstat, 7, ScalarInteger(qs->qs_re_len)); SET_STRING_ELT(DBstatnames, 7, mkChar("qs_re_len")); SET_VECTOR_ELT(DBstat, 8, ScalarInteger(qs->qs_re_pad)); SET_STRING_ELT(DBstatnames, 8, mkChar("qs_re_pad")); SET_VECTOR_ELT(DBstat, 9, ScalarInteger(qs->qs_pgfree)); SET_STRING_ELT(DBstatnames, 9, mkChar("qs_pgfree")); SET_VECTOR_ELT(DBstat, 10, ScalarInteger(qs->qs_first_recno)); SET_STRING_ELT(DBstatnames, 10, mkChar("qs_first_recno")); SET_VECTOR_ELT(DBstat, 11, ScalarInteger(qs->qs_cur_recno)); SET_STRING_ELT(DBstatnames, 11, mkChar("qs_cur_recno")); break; case DB_UNKNOWN: error("DB_UNKNOWN"); /* FIXME not too sure of correct handling here */ break; } setAttrib(DBstat, R_NamesSymbol, DBstatnames); UNPROTECT(2); return(DBstat); }
// compute pdf of a sequence of Euler steps SEXP euler_model_density (SEXP func, SEXP x, SEXP times, SEXP params, SEXP tcovar, SEXP covar, SEXP log, SEXP args, SEXP gnsi) { int nprotect = 0; pompfunmode mode = undef; int give_log; int nvars, npars, nreps, ntimes, ncovars, covlen; pomp_onestep_pdf *ff = NULL; SEXP cvec, pvec = R_NilValue; SEXP t1vec = R_NilValue, t2vec = R_NilValue; SEXP x1vec = R_NilValue, x2vec = R_NilValue; SEXP Snames, Pnames, Cnames; SEXP fn, rho = R_NilValue, fcall = R_NilValue; SEXP F; int *pidx = 0, *sidx = 0, *cidx = 0; { int *dim; dim = INTEGER(GET_DIM(x)); nvars = dim[0]; nreps = dim[1]; dim = INTEGER(GET_DIM(params)); npars = dim[0]; dim = INTEGER(GET_DIM(covar)); covlen = dim[0]; ncovars = dim[1]; ntimes = LENGTH(times); } PROTECT(Snames = GET_ROWNAMES(GET_DIMNAMES(x))); nprotect++; PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++; PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(covar))); nprotect++; // set up the covariate table struct lookup_table covariate_table = {covlen, ncovars, 0, REAL(tcovar), REAL(covar)}; // vector for interpolated covariates PROTECT(cvec = NEW_NUMERIC(ncovars)); nprotect++; SET_NAMES(cvec,Cnames); PROTECT(fn = pomp_fun_handler(func,gnsi,&mode)); nprotect++; give_log = *(INTEGER(log)); switch (mode) { case Rfun: // R function PROTECT(t1vec = NEW_NUMERIC(1)); nprotect++; PROTECT(t2vec = NEW_NUMERIC(1)); nprotect++; PROTECT(x1vec = NEW_NUMERIC(nvars)); nprotect++; SET_NAMES(x1vec,Snames); PROTECT(x2vec = NEW_NUMERIC(nvars)); nprotect++; SET_NAMES(x2vec,Snames); PROTECT(pvec = NEW_NUMERIC(npars)); nprotect++; SET_NAMES(pvec,Pnames); // set up the function call PROTECT(fcall = LCONS(cvec,args)); nprotect++; SET_TAG(fcall,install("covars")); PROTECT(fcall = LCONS(pvec,fcall)); nprotect++; SET_TAG(fcall,install("params")); PROTECT(fcall = LCONS(t2vec,fcall)); nprotect++; SET_TAG(fcall,install("t2")); PROTECT(fcall = LCONS(t1vec,fcall)); nprotect++; SET_TAG(fcall,install("t1")); PROTECT(fcall = LCONS(x2vec,fcall)); nprotect++; SET_TAG(fcall,install("x2")); PROTECT(fcall = LCONS(x1vec,fcall)); nprotect++; SET_TAG(fcall,install("x1")); PROTECT(fcall = LCONS(fn,fcall)); nprotect++; PROTECT(rho = (CLOENV(fn))); nprotect++; break; case native: // native code // construct state, parameter, covariate indices sidx = INTEGER(PROTECT(matchnames(Snames,GET_SLOT(func,install("statenames")),"state variables"))); nprotect++; pidx = INTEGER(PROTECT(matchnames(Pnames,GET_SLOT(func,install("paramnames")),"parameters"))); nprotect++; cidx = INTEGER(PROTECT(matchnames(Cnames,GET_SLOT(func,install("covarnames")),"covariates"))); nprotect++; *((void **) (&ff)) = R_ExternalPtrAddr(fn); break; default: errorcall(R_NilValue,"unrecognized 'mode' %d",mode); // # nocov break; } // create array to hold results { int dim[2] = {nreps, ntimes-1}; PROTECT(F = makearray(2,dim)); nprotect++; } switch (mode) { case Rfun: // R function { double *cp = REAL(cvec); double *t1p = REAL(t1vec); double *t2p = REAL(t2vec); double *x1p = REAL(x1vec); double *x2p = REAL(x2vec); double *pp = REAL(pvec); double *t1s = REAL(times); double *t2s = t1s+1; double *x1s = REAL(x); double *x2s = x1s + nvars*nreps; double *ps; double *fs = REAL(F); int j, k; for (k = 0; k < ntimes-1; k++, t1s++, t2s++) { // loop over times R_CheckUserInterrupt(); *t1p = *t1s; *t2p = *t2s; // interpolate the covariates at time t1, store the results in cvec table_lookup(&covariate_table,*t1p,cp); for (j = 0, ps = REAL(params); j < nreps; j++, fs++, x1s += nvars, x2s += nvars, ps += npars) { // loop over replicates memcpy(x1p,x1s,nvars*sizeof(double)); memcpy(x2p,x2s,nvars*sizeof(double)); memcpy(pp,ps,npars*sizeof(double)); *fs = *(REAL(AS_NUMERIC(eval(fcall,rho)))); if (!give_log) *fs = exp(*fs); } } } break; case native: // native code set_pomp_userdata(args); { double *t1s = REAL(times); double *t2s = t1s+1; double *x1s = REAL(x); double *x2s = x1s + nvars*nreps; double *fs = REAL(F); double *cp = REAL(cvec); double *ps; int j, k; for (k = 0; k < ntimes-1; k++, t1s++, t2s++) { // loop over times R_CheckUserInterrupt(); // interpolate the covariates at time t1, store the results in cvec table_lookup(&covariate_table,*t1s,cp); for (j = 0, ps = REAL(params); j < nreps; j++, fs++, x1s += nvars, x2s += nvars, ps += npars) { // loop over replicates (*ff)(fs,x1s,x2s,*t1s,*t2s,ps,sidx,pidx,cidx,ncovars,cp); if (!give_log) *fs = exp(*fs); } } } unset_pomp_userdata(); break; default: errorcall(R_NilValue,"unrecognized 'mode' %d",mode); // # nocov break; } UNPROTECT(nprotect); return F; }
void do_free(SEXP x) { void* addr = R_ExternalPtrAddr(x); R_Free(addr); }
static void mongoGridfileFinalizer(SEXP ptr) { if (!R_ExternalPtrAddr(ptr)) return; gridfile_destroy((gridfile*)R_ExternalPtrAddr(ptr)); R_ClearExternalPtr(ptr); }
SEXP R_setCFinalizer(SEXP extptr, SEXP sym) { R_RegisterCFinalizer(extptr, R_ExternalPtrAddr(sym)); return(R_NilValue); }
SEXP R_json_node_type(SEXP r_ref) { JSONNODE *node = (JSONNODE *) R_ExternalPtrAddr(r_ref); return(ScalarInteger( (int) json_type(node))); }
static void free_EVP_PKEY(SEXP ref) { EVP_PKEY *key = (EVP_PKEY*) R_ExternalPtrAddr(ref); if (key) EVP_PKEY_free(key); }
RcppExport SEXP xbrlProcessContexts(SEXP epaDoc) { xmlDocPtr doc = (xmlDocPtr) R_ExternalPtrAddr(epaDoc); xmlXPathContextPtr context = xmlXPathNewContext(doc); xmlXPathObjectPtr context_res = xmlXPathEvalExpression((xmlChar*) "//*[local-name()='context']", context); xmlNodeSetPtr context_nodeset = context_res->nodesetval; int context_nodeset_ln = context_nodeset->nodeNr; xmlXPathFreeContext(context); CharacterVector contextId(context_nodeset_ln); CharacterVector scheme(context_nodeset_ln); CharacterVector identifier(context_nodeset_ln); CharacterVector startDate(context_nodeset_ln); CharacterVector endDate(context_nodeset_ln); CharacterVector dimension1(context_nodeset_ln); CharacterVector value1(context_nodeset_ln); CharacterVector dimension2(context_nodeset_ln); CharacterVector value2(context_nodeset_ln); CharacterVector dimension3(context_nodeset_ln); CharacterVector value3(context_nodeset_ln); CharacterVector dimension4(context_nodeset_ln); CharacterVector value4(context_nodeset_ln); for (int i=0; i < context_nodeset_ln; i++) { xmlNodePtr context_node = context_nodeset->nodeTab[i]; xmlChar *tmp_str; if ((tmp_str = xmlGetProp(context_node, (xmlChar*) "id"))) { contextId[i] = (char *) tmp_str; xmlFree(tmp_str); } else { contextId[i] = NA_STRING; } scheme[i] = identifier[i] = startDate[i] = endDate[i] = dimension1[i] = value1[i] = dimension2[i] = value2[i] = dimension3[i] = value3[i] = dimension4[i] = value4[i] = NA_STRING; xmlNodePtr child_node = context_node->xmlChildrenNode; while (child_node) { if (!xmlStrcmp(child_node->name, (xmlChar*) "entity")) { xmlNodePtr gchild_node = child_node->xmlChildrenNode; while (gchild_node) { if (!xmlStrcmp(gchild_node->name, (xmlChar*) "identifier")) { if ((tmp_str = xmlGetProp(gchild_node, (xmlChar*) "scheme"))) { scheme[i] = (char *) tmp_str; xmlFree(tmp_str); } if ((tmp_str = xmlNodeListGetString(doc, gchild_node->xmlChildrenNode, 1))) { identifier[i] = (char *) tmp_str; xmlFree(tmp_str); } } else if (!xmlStrcmp(gchild_node->name, (xmlChar*) "segment")) { xmlNodePtr ggchild_node = gchild_node->xmlChildrenNode; int dimn = 1; while (ggchild_node) { if (!xmlStrcmp(ggchild_node->name, (xmlChar*) "explicitMember")) { if ((tmp_str = xmlGetProp(ggchild_node, (xmlChar*) "dimension"))) { if (dimn == 1) dimension1[i] = (char *) tmp_str; else if (dimn == 2) dimension2[i] = (char *) tmp_str; else if (dimn == 3) dimension3[i] = (char *) tmp_str; else if (dimn == 4) dimension4[i] = (char *) tmp_str; xmlFree(tmp_str); } if ((tmp_str = xmlNodeListGetString(doc, ggchild_node->xmlChildrenNode, 1))) { if (dimn == 1) value1[i] = (char *) tmp_str; else if (dimn == 2) value2[i] = (char *) tmp_str; else if (dimn == 3) value3[i] = (char *) tmp_str; else if (dimn == 4) value4[i] = (char *) tmp_str; xmlFree(tmp_str); } dimn++; } ggchild_node = ggchild_node->next; } } gchild_node = gchild_node->next; } } else if (!xmlStrcmp(child_node->name, (xmlChar*) "period")) { xmlNodePtr gchild_node = child_node->xmlChildrenNode; while (gchild_node) { if (!xmlStrcmp(gchild_node->name, (xmlChar*) "startDate")) { if ((tmp_str = xmlNodeListGetString(doc, gchild_node->xmlChildrenNode, 1))) { startDate[i] = (char *) tmp_str; xmlFree(tmp_str); } } else if (!xmlStrcmp(gchild_node->name, (xmlChar*) "endDate")) { if ((tmp_str = xmlNodeListGetString(doc, gchild_node->xmlChildrenNode, 1))) { endDate[i] = (char *) tmp_str; xmlFree(tmp_str); } } else if (!xmlStrcmp(gchild_node->name, (xmlChar*) "instant")) { if ((tmp_str = xmlNodeListGetString(doc, gchild_node->xmlChildrenNode, 1))) { endDate[i] = (char *) tmp_str; xmlFree(tmp_str); } } gchild_node = gchild_node->next; } } child_node = child_node->next; } } xmlXPathFreeObject(context_res); return DataFrame::create(Named("contextId")=contextId, Named("scheme")=scheme, Named("identifier")=identifier, Named("startDate")=startDate, Named("endDate")=endDate, Named("dimension1")=dimension1, Named("value1")=value1, Named("dimension2")=dimension2, Named("value2")=value2, Named("dimension3")=dimension3, Named("value3")=value3, Named("dimension4")=dimension4, Named("value4")=value4); }
RcppExport SEXP xbrlProcessUnits(SEXP epaDoc) { xmlDocPtr doc = (xmlDocPtr) R_ExternalPtrAddr(epaDoc); xmlXPathContextPtr context = xmlXPathNewContext(doc); xmlXPathObjectPtr unit_res = xmlXPathEvalExpression((xmlChar*) "//*[local-name()='unit']", context); xmlNodeSetPtr unit_nodeset = unit_res->nodesetval; int unit_nodeset_ln = unit_nodeset->nodeNr; xmlXPathFreeContext(context); CharacterVector unitId(unit_nodeset_ln); CharacterVector measure(unit_nodeset_ln); CharacterVector unitNumerator(unit_nodeset_ln); CharacterVector unitDenominator(unit_nodeset_ln); for (int i=0; i < unit_nodeset_ln; i++) { xmlNodePtr unit_node = unit_nodeset->nodeTab[i]; xmlChar *tmp_str; if ((tmp_str = xmlGetProp(unit_node, (xmlChar*) "id"))) { unitId[i] = (char *) tmp_str; xmlFree(tmp_str); } else { unitId[i] = NA_STRING; } measure[i] = unitNumerator[i] = unitDenominator[i] = NA_STRING; xmlNodePtr child_node = unit_node->xmlChildrenNode; while (child_node) { if (!xmlStrcmp(child_node->name, (xmlChar*) "measure")) { if ((tmp_str = xmlNodeListGetString(doc, child_node->xmlChildrenNode, 1))) { measure[i] = (char *) tmp_str; xmlFree(tmp_str); } } else if (!xmlStrcmp(child_node->name, (xmlChar*) "divide")) { xmlNodePtr gchild_node = child_node->xmlChildrenNode; while (gchild_node) { if (!xmlStrcmp(gchild_node->name, (xmlChar*) "unitNumerator")) { xmlNodePtr ggchild_node = gchild_node->xmlChildrenNode; while (ggchild_node) { if (!xmlStrcmp(ggchild_node->name, (xmlChar*) "measure")) { if ((tmp_str = xmlNodeListGetString(doc, ggchild_node->xmlChildrenNode, 1))) { unitNumerator[i] = (char *) tmp_str; xmlFree(tmp_str); } } ggchild_node = ggchild_node->next; } } else if (!xmlStrcmp(gchild_node->name, (xmlChar*) "unitDenominator")) { xmlNodePtr ggchild_node = gchild_node->xmlChildrenNode; while (ggchild_node) { if (!xmlStrcmp(ggchild_node->name, (xmlChar*) "measure")) { if ((tmp_str = xmlNodeListGetString(doc, ggchild_node->xmlChildrenNode, 1))) { unitDenominator[i] = (char *) tmp_str; xmlFree(tmp_str); } } ggchild_node = ggchild_node->next; } } gchild_node = gchild_node->next; } } child_node = child_node->next; } } xmlXPathFreeObject(unit_res); return DataFrame::create(Named("unitId")=unitId, Named("measure")=measure, Named("unitNumerator")=unitNumerator, Named("unitDenominator")=unitDenominator); }
SEXP r_all_branches_cont(SEXP extPtr, SEXP r_pars) { dt_obj_cont *obj = (dt_obj_cont*)R_ExternalPtrAddr(extPtr); double *pars = REAL(r_pars); int neq, n_tip, n_int, *children, *order, *tip_target; double *len, *depth, *init, *base, *lq; DtIcFun ic; DtBrFun br; int i, idx, *kids; double tot = 0.0; SEXP ret, ret_vals; if ( obj == NULL ) error("Corrupt pointer (are you using multicore?)"); ic = obj->ic; br = obj->br; neq = obj->neq; n_tip = obj->n_tip; n_int = obj->n_int; tip_target = obj->tip_target; children = obj->children; order = obj->order; len = obj->len; depth = obj->depth; init = obj->init; base = obj->base; lq = obj->lq; if ( LENGTH(r_pars) != obj->np ) error("Incorrect length parameters. Expected %d, got %d", obj->np, LENGTH(r_pars)); for ( i = 0; i < n_tip; i++ ) { idx = tip_target[i]; lq[idx] = br(init + neq * idx, len[idx], pars, depth[idx], idx, base + neq * idx); } for ( i = 0; i < n_int; i++ ) { idx = order[i]; kids = children + idx * 2; ic(neq, base + neq*kids[0], base + neq*kids[1], pars, depth[idx], init + neq * idx); lq[idx] = br(init + neq * idx, len[idx], pars, depth[idx], idx, base + neq * idx); } idx = obj->root; kids = children + idx * 2; ic(neq, base + neq*kids[0], base + neq*kids[1], pars, depth[idx], init + neq * idx); lq[obj->root] = 0.0; /* defensive */ for ( i = 0; i < obj->n_out; i++ ) tot += lq[i]; PROTECT(ret = allocVector(VECSXP, 2)); PROTECT(ret_vals = allocVector(REALSXP, neq)); SET_VECTOR_ELT(ret, 0, ScalarReal(tot)); SET_VECTOR_ELT(ret, 1, ret_vals); memcpy(REAL(ret_vals), init + obj->root * neq, neq*sizeof(double)); UNPROTECT(2); return ret; }
/* entry point to wm_show_wm */ void scoss_show_wm(SEXP wmR) { WeightMatrix* wm = (WeightMatrix *) R_ExternalPtrAddr(wmR); show_wm(wm); }