// 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);
}
