SEXP RCatnetSearchP::estimate(SEXP rSamples, SEXP rPerturbations, SEXP rClasses, SEXP rClsdist,
SEXP rMaxParents, SEXP rParentSizes, SEXP rMaxComplexity, SEXP rOrder, SEXP rNodeCats,
SEXP rParentsPool, SEXP rFixedParentsPool, SEXP rMatEdgeLiks, SEXP rUseCache, SEXP rEcho) {
int i, ii, j, k, len, sampleline, bUseCache, maxParentSet, maxComplexity, numnets, inet, echo, klmode;
int *pRperturbations, *pPerturbations, *pNodeOffsets,
**parentsPool, **fixedParentsPool, *pPool, *pParentSizes,
hasClasses, *pRclasses, *pClasses;
double *pRsamples, *pSamples, *matEdgeLiks, *pMatEdgeLiks;
RCatnetP rcatnet;
SEXP dim, rnodecat, rparpool, cnetlist, cnetnode;
if(!isMatrix(rSamples))
error("Data is not a matrix");
Rprintf("RCatnetSearchP\n");
PROTECT(rMaxParents = AS_INTEGER(rMaxParents));
maxParentSet = INTEGER_POINTER(rMaxParents)[0];
UNPROTECT(1);
PROTECT(rMaxComplexity = AS_INTEGER(rMaxComplexity));
maxComplexity = INTEGER_POINTER(rMaxComplexity)[0];
UNPROTECT(1);
PROTECT(rUseCache = AS_LOGICAL(rUseCache));
bUseCache = LOGICAL(rUseCache)[0];
//Rprintf("bUseCache = %d\n", bUseCache);
UNPROTECT(1);
PROTECT(rEcho = AS_LOGICAL(rEcho));
echo = LOGICAL(rEcho)[0];
UNPROTECT(1);
klmode = 0;
PROTECT(rClsdist = AS_INTEGER(rClsdist));
klmode = INTEGER_POINTER(rClsdist)[0];
UNPROTECT(1);
hasClasses = 0;
if(!isNull(rClasses) && isInteger(rClasses))
hasClasses = 1;
dim = GET_DIM(rSamples);
sampleline = INTEGER(dim)[0];
m_numSamples = INTEGER(dim)[1];
if(isNull(rNodeCats))
error("Node categories must be specified");
m_numNodes = length(rNodeCats);
if(m_pSearchParams)
delete m_pSearchParams;
m_pSearchParams = new SEARCH_PARAMETERS(
m_numNodes, m_numSamples,
maxParentSet, maxComplexity, echo,
!isNull(rNodeCats),
!isNull(rParentSizes), !isNull(rPerturbations),
!isNull(rParentsPool), !isNull(rFixedParentsPool),
!isNull(rMatEdgeLiks), 0,
NULL, this, sampleline, 0, hasClasses, klmode);
if (!m_pSearchParams) {
CATNET_MEM_ERR();
}
if(m_pRorder)
CATNET_FREE(m_pRorder);
m_pRorder = (int*)CATNET_MALLOC(m_numNodes*sizeof(int));
if(m_pRorderInverse)
CATNET_FREE(m_pRorderInverse);
m_pRorderInverse = (int*)CATNET_MALLOC(m_numNodes*sizeof(int));
if (!m_pRorder || !m_pRorderInverse) {
CATNET_MEM_ERR();
}
PROTECT(rOrder = AS_INTEGER(rOrder));
if(length(rOrder) < m_numNodes) {
warning("Invalid nodeOrder parameter - reset to default node order.");
for(i = 0; i < m_numNodes; i++)
m_pRorder[i] = i + 1;
}
else {
memcpy(m_pRorder, INTEGER(rOrder), m_numNodes*sizeof(int));
}
for(i = 0; i < m_numNodes; i++) {
if(m_pRorder[i] <= 0 || m_pRorder[i] > m_numNodes) {
error("Invalid nodeOrder parameter");
}
else
m_pRorderInverse[m_pRorder[i]-1] = i + 1;
}
UNPROTECT(1);
pNodeOffsets = (int*)CATNET_MALLOC(m_numNodes*sizeof(int));
if (!pNodeOffsets) {
CATNET_MEM_ERR();
}
memset(pNodeOffsets, 0, m_numNodes*sizeof(int));
PROTECT(rNodeCats = AS_LIST(rNodeCats));
for(i = 0; i < m_numNodes; i++) {
rnodecat = AS_INTEGER(VECTOR_ELT(rNodeCats, i));
len = length(rnodecat);
pNodeOffsets[i] = len;
if(i > 0)
pNodeOffsets[i] = pNodeOffsets[i-1] + len;
if(isVector(rnodecat) && len > 0) {
m_pSearchParams->m_pNodeNumCats[i] = len;
m_pSearchParams->m_pNodeCats[i] = (int*)CATNET_MALLOC(len*sizeof(int));
if (m_pSearchParams->m_pNodeCats[i]) {
for(j = 0; j < len; j++)
m_pSearchParams->m_pNodeCats[i][j] = INTEGER(rnodecat)[j];
}
}
}
for(i = m_numNodes - 1; i > 0; i--)
pNodeOffsets[i] = pNodeOffsets[i-1];
pNodeOffsets[0] = 0;
UNPROTECT(1);
if(!isNull(rParentSizes)) {
pParentSizes = m_pSearchParams->m_pParentSizes;
PROTECT(rParentSizes = AS_INTEGER(rParentSizes));
if(length(rParentSizes) == m_numNodes) {
for(i = 0; i < m_numNodes; i++)
pParentSizes[i] = INTEGER(rParentSizes)[m_pRorder[i] - 1];
}
UNPROTECT(1);
}
PROTECT(rSamples = AS_NUMERIC(rSamples));
pSamples = (double*)m_pSearchParams->m_pSamples;
pRsamples = REAL(rSamples);
if (pSamples && pRsamples) {
ii = 0;
for(i = 0; i < m_numNodes; i++) {
for(j = 0; j < m_numSamples; j++) {
memcpy(pSamples+j*sampleline + ii,
pRsamples+j*sampleline + pNodeOffsets[m_pRorder[i] - 1],
m_pSearchParams->m_pNodeNumCats[i]*sizeof(double));
if(R_IsNA(pSamples[j*sampleline + ii]) || pSamples[j*sampleline + ii] < 0) {
pSamples[j*sampleline + ii] = CATNET_NAN;
}
}
ii += m_pSearchParams->m_pNodeNumCats[i];
}
}
UNPROTECT(1); // rSamples
CATNET_FREE(pNodeOffsets);
pNodeOffsets = 0;
pPerturbations = 0;
if(!isNull(rPerturbations)) {
PROTECT(rPerturbations = AS_INTEGER(rPerturbations));
pPerturbations = m_pSearchParams->m_pPerturbations;
pRperturbations = INTEGER_POINTER(rPerturbations);
for(j = 0; j < m_numSamples; j++) {
for(i = 0; i < m_numNodes; i++) {
pPerturbations[j*m_numNodes + i] = pRperturbations[j*m_numNodes + m_pRorder[i] - 1];
}
}
UNPROTECT(1);
}
if(hasClasses) {
PROTECT(rClasses = AS_INTEGER(rClasses));
pClasses = (int*)m_pSearchParams->m_pClasses;
pRclasses = INTEGER(rClasses);
if (pClasses && pRclasses)
memcpy(pClasses, pRclasses, m_numSamples*sizeof(int));
UNPROTECT(1); // rClasses
}
parentsPool = 0;
if(!isNull(rParentsPool)) {
PROTECT(rParentsPool = AS_LIST(rParentsPool));
parentsPool = m_pSearchParams->m_parentsPool;
for(i = 0; i < m_numNodes; i++) {
rparpool = AS_INTEGER(VECTOR_ELT(rParentsPool, (int)(m_pRorder[i] - 1)));
len = length(rparpool);
if(isVector(rparpool) && len > 0 && len <= m_numNodes) {
parentsPool[i] = (int*)CATNET_MALLOC((len+1)*sizeof(int));
pPool = INTEGER(rparpool);
if (parentsPool[i] && pPool) {
for(j = 0; j < len; j++) {
if(pPool[j] > 0 && pPool[j] <= m_numNodes) {
for(k = 0; k < m_numNodes; k++)
if(pPool[j] == m_pRorder[k])
break;
if(k < m_numNodes)
parentsPool[i][j] = k;
else
parentsPool[i][j] = -1;
}
}
parentsPool[i][len] = -1;
}
if(m_pSearchParams->m_maxParentsPool < len)
m_pSearchParams->m_maxParentsPool = len;
}
}
UNPROTECT(1);
}
fixedParentsPool = 0;
if(!isNull(rFixedParentsPool)) {
PROTECT(rFixedParentsPool = AS_LIST(rFixedParentsPool));
fixedParentsPool = m_pSearchParams->m_fixedParentsPool;
for(i = 0; i < m_numNodes; i++) {
rparpool = AS_INTEGER(VECTOR_ELT(rFixedParentsPool, (int)(m_pRorder[i] - 1)));
len = length(rparpool);
if(isVector(rparpool) && len > 0 && len <= m_numNodes) {
fixedParentsPool[i] = (int*)CATNET_MALLOC((len+1)*sizeof(int));
if(maxParentSet < len)
maxParentSet = len;
pPool = INTEGER(rparpool);
if (fixedParentsPool[i] && pPool) {
for(j = 0; j < len; j++) {
if(pPool[j] > 0 && pPool[j] <= m_numNodes) {
for(k = 0; k < m_numNodes; k++)
if(pPool[j] == m_pRorder[k])
break;
if(k < m_numNodes)
fixedParentsPool[i][j] = k;
else
fixedParentsPool[i][j] = -1;
}
}
}
fixedParentsPool[i][len] = -1;
if(m_pSearchParams->m_maxParentsPool < len)
m_pSearchParams->m_maxParentsPool = len;
}
}
UNPROTECT(1);
}
if(!isNull(rMatEdgeLiks) && m_pSearchParams->m_matEdgeLiks) {
PROTECT(rMatEdgeLiks = AS_NUMERIC(rMatEdgeLiks));
matEdgeLiks = m_pSearchParams->m_matEdgeLiks;
pMatEdgeLiks = REAL(rMatEdgeLiks);
for(j = 0; j < m_numNodes; j++) {
for(i = 0; i < m_numNodes; i++) {
matEdgeLiks[j*m_numNodes + i] = pMatEdgeLiks[(m_pRorder[j] - 1)*m_numNodes + m_pRorder[i] - 1];
}
}
UNPROTECT(1);
}
if(bUseCache)
setCacheParams(m_numNodes, maxParentSet, m_pRorder, m_pRorderInverse);
search(m_pSearchParams);
if(m_pSearchParams)
delete m_pSearchParams;
m_pSearchParams = 0;
if(!m_nCatnets || !m_pCatnets) {
warning("No networks are found");
return R_NilValue;
}
// create a R-list of catNetworks
numnets = 0;
for(i = 0; i < m_nCatnets; i++) {
if(m_pCatnets[i]) {
m_pCatnets[i]->setNodesOrder(m_pRorder);
numnets++;
}
}
PROTECT(cnetlist = allocVector(VECSXP, numnets));
inet = 0;
for(i = 0; i < m_nCatnets; i++) {
if(!m_pCatnets[i])
continue;
rcatnet = *m_pCatnets[i];
PROTECT(cnetnode = rcatnet.genRcatnet("catNetwork"));
SET_VECTOR_ELT(cnetlist, inet, cnetnode);
UNPROTECT(1);
inet++;
}
UNPROTECT(1);
if(m_pRorder)
CATNET_FREE(m_pRorder);
m_pRorder = 0;
if(m_pRorderInverse)
CATNET_FREE(m_pRorderInverse);
m_pRorderInverse = 0;
Rprintf("estimate exit");
return cnetlist;
}
// examines weights for filtering failure
// computes log likelihood and effective sample size
// computes (if desired) prediction mean, prediction variance, filtering mean.
// it is assumed that ncol(x) == ncol(params).
// weights are used in filtering mean computation.
// if length(weights) == 1, an unweighted average is computed.
// returns all of the above in a named list
SEXP pfilter2_computations (SEXP x, SEXP params, SEXP Np,
SEXP rw, SEXP rw_sd,
SEXP predmean, SEXP predvar,
SEXP filtmean, SEXP onepar,
SEXP weights, SEXP tol)
{
int nprotect = 0;
SEXP pm = R_NilValue, pv = R_NilValue, fm = R_NilValue;
SEXP rw_names, ess, fail, loglik;
SEXP newstates = R_NilValue, newparams = R_NilValue;
SEXP retval, retvalnames;
double *xpm = 0, *xpv = 0, *xfm = 0, *xw = 0, *xx = 0, *xp = 0, *xpw=0;
int *xpa=0;
SEXP dimX, dimP, newdim, Xnames, Pnames, pindex;
SEXP pw=R_NilValue,pa=R_NilValue, psample=R_NilValue;
int *dim, *pidx, lv, np;
int nvars, npars = 0, nrw = 0, nreps, offset, nlost;
int do_rw, do_pm, do_pv, do_fm, do_par_resamp, all_fail = 0;
double sum, sumsq, vsq, ws, w, toler;
int j, k;
PROTECT(dimX = GET_DIM(x)); nprotect++;
dim = INTEGER(dimX);
nvars = dim[0]; nreps = dim[1];
xx = REAL(x);
PROTECT(Xnames = GET_ROWNAMES(GET_DIMNAMES(x))); nprotect++;
PROTECT(dimP = GET_DIM(params)); nprotect++;
dim = INTEGER(dimP);
npars = dim[0];
if (nreps != dim[1])
error("'states' and 'params' do not agree in second dimension");
PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++;
np = INTEGER(AS_INTEGER(Np))[0]; // number of particles to resample
PROTECT(rw_names = GET_NAMES(rw_sd)); nprotect++; // names of parameters undergoing random walk
do_rw = *(LOGICAL(AS_LOGICAL(rw))); // do random walk in parameters?
do_pm = *(LOGICAL(AS_LOGICAL(predmean))); // calculate prediction means?
do_pv = *(LOGICAL(AS_LOGICAL(predvar))); // calculate prediction variances?
do_fm = *(LOGICAL(AS_LOGICAL(filtmean))); // calculate filtering means?
do_par_resamp = *(LOGICAL(AS_LOGICAL(onepar))); // are all cols of 'params' the same?
do_par_resamp = !do_par_resamp || do_rw || (np != nreps); // should we do parameter resampling?
PROTECT(ess = NEW_NUMERIC(1)); nprotect++; // effective sample size
PROTECT(loglik = NEW_NUMERIC(1)); nprotect++; // log likelihood
PROTECT(fail = NEW_LOGICAL(1)); nprotect++; // particle failure?
xw = REAL(weights);
toler = *(REAL(tol)); // failure tolerance
// check the weights and compute sum and sum of squares
for (k = 0, w = 0, ws = 0, nlost = 0; k < nreps; k++) {
if (xw[k] >= 0) {
w += xw[k];
ws += xw[k]*xw[k];
} else { // this particle is lost
xw[k] = 0;
nlost++;
}
}
if (nlost >= nreps) all_fail = 1; // all particles are lost
if (all_fail) {
*(REAL(loglik)) = log(toler); // minimum log-likelihood
*(REAL(ess)) = 0; // zero effective sample size
} else {
*(REAL(loglik)) = log(w/((double) nreps)); // mean of weights is likelihood
*(REAL(ess)) = w*w/ws; // effective sample size
}
*(LOGICAL(fail)) = all_fail;
if (do_rw) {
// indices of parameters undergoing random walk
PROTECT(pindex = matchnames(Pnames,rw_names,"parameters")); nprotect++;
xp = REAL(params);
pidx = INTEGER(pindex);
nrw = LENGTH(rw_names);
lv = nvars+nrw;
} else {
pidx = NULL;
lv = nvars;
}
if (do_pm || do_pv) {
PROTECT(pm = NEW_NUMERIC(lv)); nprotect++;
xpm = REAL(pm);
}
if (do_pv) {
PROTECT(pv = NEW_NUMERIC(lv)); nprotect++;
xpv = REAL(pv);
}
if (do_fm) {
if (do_rw) {
PROTECT(fm = NEW_NUMERIC(nvars+npars)); nprotect++;
} else {
PROTECT(fm = NEW_NUMERIC(nvars)); nprotect++;
}
xfm = REAL(fm);
}
PROTECT(pa = NEW_INTEGER(np)); nprotect++;
xpa = INTEGER(pa);
for (j = 0; j < nvars; j++) { // state variables
// compute prediction mean
if (do_pm || do_pv) {
for (k = 0, sum = 0; k < nreps; k++) sum += xx[j+k*nvars];
sum /= ((double) nreps);
xpm[j] = sum;
}
// compute prediction variance
if (do_pv) {
for (k = 0, sumsq = 0; k < nreps; k++) {
vsq = xx[j+k*nvars]-sum;
sumsq += vsq*vsq;
}
xpv[j] = sumsq / ((double) (nreps - 1));
}
// compute filter mean
if (do_fm) {
if (all_fail) { // unweighted average
for (k = 0, ws = 0; k < nreps; k++) ws += xx[j+k*nvars];
xfm[j] = ws/((double) nreps);
} else { // weighted average
for (k = 0, ws = 0; k < nreps; k++) ws += xx[j+k*nvars]*xw[k];
xfm[j] = ws/w;
}
}
}
// compute means and variances for parameters (if needed)
if (do_rw) {
for (j = 0; j < nrw; j++) {
offset = pidx[j]; // position of the parameter
if (do_pm || do_pv) {
for (k = 0, sum = 0; k < nreps; k++) sum += xp[offset+k*npars];
sum /= ((double) nreps);
xpm[nvars+j] = sum;
}
if (do_pv) {
for (k = 0, sumsq = 0; k < nreps; k++) {
vsq = xp[offset+k*npars]-sum;
sumsq += vsq*vsq;
}
xpv[nvars+j] = sumsq / ((double) (nreps - 1));
}
}
if (do_fm) {
for (j = 0; j < npars; j++) {
if (all_fail) { // unweighted average
for (k = 0, ws = 0; k < nreps; k++) ws += xp[j+k*npars];
xfm[nvars+j] = ws/((double) nreps);
} else { // weighted average
for (k = 0, ws = 0; k < nreps; k++) ws += xp[j+k*npars]*xw[k];
xfm[nvars+j] = ws/w;
}
}
}
}
GetRNGstate();
if (!all_fail) { // resample the particles unless we have filtering failure
int xdim[2];
//int sample[np];
double *ss = 0, *st = 0, *ps = 0, *pt = 0;
// create storage for new states
xdim[0] = nvars; xdim[1] = np;
PROTECT(newstates = makearray(2,xdim)); nprotect++;
setrownames(newstates,Xnames,2);
ss = REAL(x);
st = REAL(newstates);
// create storage for new parameters
if (do_par_resamp) {
xdim[0] = npars; xdim[1] = np;
PROTECT(newparams = makearray(2,xdim)); nprotect++;
setrownames(newparams,Pnames,2);
ps = REAL(params);
pt = REAL(newparams);
}
PROTECT(pw = NEW_NUMERIC(nreps)); nprotect++;
xpw = REAL(pw);
for (k = 0; k < nreps; k++)
xpw[k]=REAL(weights)[k];
nosort_resamp(nreps,REAL(weights),np,xpa,0);
for (k = 0; k < np; k++) { // copy the particles
for (j = 0, xx = ss+nvars*xpa[k]; j < nvars; j++, st++, xx++)
*st = *xx;
if (do_par_resamp) {
for (j = 0, xp = ps+npars*xpa[k]; j < npars; j++, pt++, xp++){
*pt = *xp;
}
}
}
} else { // don't resample: just drop 3rd dimension in x prior to return
PROTECT(newdim = NEW_INTEGER(2)); nprotect++;
dim = INTEGER(newdim);
dim[0] = nvars; dim[1] = nreps;
SET_DIM(x,newdim);
setrownames(x,Xnames,2);
}
if (do_rw) { // if random walk, adjust prediction variance and move particles
xx = REAL(rw_sd);
xp = (all_fail || !do_par_resamp) ? REAL(params) : REAL(newparams);
nreps = (all_fail) ? nreps : np;
for (j = 0; j < nrw; j++) {
offset = pidx[j];
vsq = xx[j];
if (do_pv) {
xpv[nvars+j] += vsq*vsq;
}
for (k = 0; k < nreps; k++)
xp[offset+k*npars] += rnorm(0,vsq);
}
}
renormalize(xpw,nreps,0);
PutRNGstate();
PROTECT(retval = NEW_LIST(10)); nprotect++;
PROTECT(retvalnames = NEW_CHARACTER(10)); nprotect++;
SET_STRING_ELT(retvalnames,0,mkChar("fail"));
SET_STRING_ELT(retvalnames,1,mkChar("loglik"));
SET_STRING_ELT(retvalnames,2,mkChar("ess"));
SET_STRING_ELT(retvalnames,3,mkChar("states"));
SET_STRING_ELT(retvalnames,4,mkChar("params"));
SET_STRING_ELT(retvalnames,5,mkChar("pm"));
SET_STRING_ELT(retvalnames,6,mkChar("pv"));
SET_STRING_ELT(retvalnames,7,mkChar("fm"));
SET_STRING_ELT(retvalnames,8,mkChar("weight"));
SET_STRING_ELT(retvalnames,9,mkChar("pa"));
SET_NAMES(retval,retvalnames);
SET_ELEMENT(retval,0,fail);
SET_ELEMENT(retval,1,loglik);
SET_ELEMENT(retval,2,ess);
if (all_fail) {
SET_ELEMENT(retval,3,x);
} else {
SET_ELEMENT(retval,3,newstates);
}
if (all_fail || !do_par_resamp) {
SET_ELEMENT(retval,4,params);
} else {
SET_ELEMENT(retval,4,newparams);
}
if (do_pm) {
SET_ELEMENT(retval,5,pm);
}
if (do_pv) {
SET_ELEMENT(retval,6,pv);
}
if (do_fm) {
SET_ELEMENT(retval,7,fm);
}
SET_ELEMENT(retval,8,pw);
SET_ELEMENT(retval,9,pa);
UNPROTECT(nprotect);
return(retval);
}
SEXP RDagSearch::estimate(SEXP rSamples, SEXP rPerturbations, SEXP rClasses, SEXP rClsdist,
SEXP rMaxParents, SEXP rParentSizes, SEXP rMaxComplexity, SEXP rOrder, SEXP rNodeCats,
SEXP rParentsPool, SEXP rFixedParentsPool, SEXP rMatEdgeLiks, SEXP rUseCache, SEXP rEcho, int bIntSample = 0) {
int i, j, k, len, maxParentSet, maxCategories, maxComplexity, bEqualCategories, node, echo, klmode;
int *pRperturbations, *pPerturbations, **parentsPool, **fixedParentsPool, *pPool, *pParentSizes;
double *matEdgeLiks, *pMatEdgeLiks;
SEXP dim, rnodecat, rparpool;
int sampleline, *pNodeOffsets;
int *pRsamples, *pSamples;
double *pfRsamples, *pfSamples;
DAG_LIST<double, int> *pDagList;
int hasClasses, *pRclasses, *pClasses;
if(!isMatrix(rSamples))
error("Data is not a matrix");
PROTECT(rMaxParents = AS_INTEGER(rMaxParents));
maxParentSet = INTEGER_POINTER(rMaxParents)[0];
UNPROTECT(1);
PROTECT(rMaxComplexity = AS_INTEGER(rMaxComplexity));
maxComplexity = INTEGER_POINTER(rMaxComplexity)[0];
UNPROTECT(1);
PROTECT(rEcho = AS_LOGICAL(rEcho));
echo = LOGICAL(rEcho)[0];
UNPROTECT(1);
klmode = 0;
PROTECT(rClsdist = AS_INTEGER(rClsdist));
klmode = INTEGER_POINTER(rClsdist)[0];
UNPROTECT(1);
hasClasses = 0;
if(!isNull(rClasses) && isInteger(rClasses))
hasClasses = 1;
sampleline = 0;
if(bIntSample) {
dim = GET_DIM(rSamples);
m_numNodes = INTEGER(dim)[0];
m_numSamples = INTEGER(dim)[1];
}
else {
dim = GET_DIM(rSamples);
sampleline = INTEGER(dim)[0];
m_numSamples = INTEGER(dim)[1];
if(isNull(rNodeCats))
error("Node categories must be specified");
m_numNodes = length(rNodeCats);
}
if(m_pRorder)
CATNET_FREE(m_pRorder);
m_pRorder = (int*)CATNET_MALLOC(m_numNodes*sizeof(int));
if (!m_pRorder) {
CATNET_MEM_ERR();
}
PROTECT(rOrder = AS_INTEGER(rOrder));
if(length(rOrder) < m_numNodes) {
warning("Invalid nodeOrder parameter - reset to default node order.");
for(i = 0; i < m_numNodes; i++)
m_pRorder[i] = i + 1;
}
else {
memcpy(m_pRorder, INTEGER(rOrder), m_numNodes*sizeof(int));
}
UNPROTECT(1);
if(m_pSearchParams)
delete m_pSearchParams;
m_pSearchParams = new SEARCH_PARAMETERS(
m_numNodes, m_numSamples,
maxParentSet, maxComplexity, echo,
!isNull(rNodeCats),
!isNull(rParentSizes), !isNull(rPerturbations),
!isNull(rParentsPool), !isNull(rFixedParentsPool),
!isNull(rMatEdgeLiks), 0,
NULL, this, sampleline, 0, hasClasses, klmode);
if (!m_pSearchParams) {
CATNET_MEM_ERR();
}
pPerturbations = 0;
if(!isNull(rPerturbations)) {
PROTECT(rPerturbations = AS_INTEGER(rPerturbations));
pPerturbations = m_pSearchParams->m_pPerturbations;
pRperturbations = INTEGER_POINTER(rPerturbations);
for(j = 0; j < m_numSamples; j++) {
for(i = 0; i < m_numNodes; i++) {
pPerturbations[j*m_numNodes + i] = pRperturbations[j*m_numNodes + m_pRorder[i] - 1];
}
}
UNPROTECT(1);
}
if(hasClasses) {
pClasses = (int*)m_pSearchParams->m_pClasses;
PROTECT(rClasses = AS_INTEGER(rClasses));
pRclasses = INTEGER(rClasses);
memcpy(pClasses, pRclasses, m_numSamples*sizeof(int));
UNPROTECT(1); // rClasses
}
parentsPool = 0;
if(!isNull(rParentsPool)) {
PROTECT(rParentsPool = AS_LIST(rParentsPool));
parentsPool = m_pSearchParams->m_parentsPool;
for(i = 0; i < m_numNodes; i++) {
rparpool = AS_INTEGER(VECTOR_ELT(rParentsPool, (int)(m_pRorder[i] - 1)));
len = length(rparpool);
if(isVector(rparpool) && len > 0 && len <= m_numNodes) {
parentsPool[i] = (int*)CATNET_MALLOC((len+1)*sizeof(int));
pPool = INTEGER(rparpool);
if (parentsPool[i] && pPool) {
for(j = 0; j < len; j++) {
if(pPool[j] > 0 && pPool[j] <= m_numNodes) {
for(k = 0; k < m_numNodes; k++)
if(pPool[j] == m_pRorder[k])
break;
if(k < m_numNodes)
parentsPool[i][j] = k;
else
parentsPool[i][j] = -1;
}
}
parentsPool[i][len] = -1;
}
if(m_pSearchParams->m_maxParentsPool < len)
m_pSearchParams->m_maxParentsPool = len;
}
}
UNPROTECT(1);
}
fixedParentsPool = 0;
if(!isNull(rFixedParentsPool)) {
PROTECT(rFixedParentsPool = AS_LIST(rFixedParentsPool));
fixedParentsPool = m_pSearchParams->m_fixedParentsPool;
for(i = 0; i < m_numNodes; i++) {
rparpool = AS_INTEGER(VECTOR_ELT(rFixedParentsPool, (int)(m_pRorder[i] - 1)));
len = length(rparpool);
if(isVector(rparpool) && len > 0 && len <= m_numNodes) {
fixedParentsPool[i] = (int*)CATNET_MALLOC((len+1)*sizeof(int));
if(maxParentSet < len)
maxParentSet = len;
pPool = INTEGER(rparpool);
if (fixedParentsPool[i] && pPool) {
for(j = 0; j < len; j++) {
if(pPool[j] > 0 && pPool[j] <= m_numNodes) {
for(k = 0; k < m_numNodes; k++)
if(pPool[j] == m_pRorder[k])
break;
if(k < m_numNodes)
fixedParentsPool[i][j] = k;
else
fixedParentsPool[i][j] = -1;
}
}
fixedParentsPool[i][len] = -1;
}
if(m_pSearchParams->m_maxParentsPool < len)
m_pSearchParams->m_maxParentsPool = len;
}
}
UNPROTECT(1);
}
if(!isNull(rMatEdgeLiks) && m_pSearchParams->m_matEdgeLiks) {
PROTECT(rMatEdgeLiks = AS_NUMERIC(rMatEdgeLiks));
matEdgeLiks = m_pSearchParams->m_matEdgeLiks;
pMatEdgeLiks = REAL(rMatEdgeLiks);
for(j = 0; j < m_numNodes; j++) {
for(i = 0; i < m_numNodes; i++) {
matEdgeLiks[j*m_numNodes + i] = pMatEdgeLiks[(m_pRorder[j] - 1)*m_numNodes + m_pRorder[i] - 1];
}
}
UNPROTECT(1);
}
if(!isNull(rParentSizes)) {
pParentSizes = m_pSearchParams->m_pParentSizes;
PROTECT(rParentSizes = AS_INTEGER(rParentSizes));
if(length(rParentSizes) == m_numNodes) {
for(i = 0; i < m_numNodes; i++)
pParentSizes[i] = INTEGER(rParentSizes)[m_pRorder[i] - 1];
}
UNPROTECT(1);
}
pDagList = 0;
if(bIntSample) {
PROTECT(rSamples = AS_INTEGER(rSamples));
pSamples = (int*)m_pSearchParams->m_pSamples;
pRsamples = INTEGER(rSamples);
for(j = 0; j < m_numSamples; j++) {
for(i = 0; i < m_numNodes; i++) {
pSamples[j*m_numNodes + i] = pRsamples[j*m_numNodes + m_pRorder[i] - 1];
if(R_IsNA(pSamples[j*m_numNodes + i]) || pSamples[j*m_numNodes + i] < 1) {
pSamples[j*m_numNodes + i] = CATNET_NAN;
}
}
}
UNPROTECT(1); // rSamples
maxCategories = 0;
if(!isNull(rNodeCats)) {
PROTECT(rNodeCats = AS_LIST(rNodeCats));
for(i = 0; i < m_numNodes; i++) {
rnodecat = AS_INTEGER(VECTOR_ELT(rNodeCats, (int)(m_pRorder[i] - 1)));
len = length(rnodecat);
if(maxCategories < len)
maxCategories = len;
//if(maxCategories > 0 && maxCategories != len)
// CATNET_ERR("Nodes should have equal number of categories");
if(isVector(rnodecat) && len > 0) {
m_pSearchParams->m_pNodeNumCats[i] = len;
m_pSearchParams->m_pNodeCats[i] = (int*)CATNET_MALLOC(len*sizeof(int));
if (!m_pSearchParams->m_pNodeCats[i]) {
CATNET_MEM_ERR();
}
for(j = 0; j < len; j++)
m_pSearchParams->m_pNodeCats[i][j] = INTEGER(rnodecat)[j];
}
}
UNPROTECT(1);
}
bEqualCategories = 1;
for(i = 0; i < m_numNodes; i++)
if(i > 1 && m_pSearchParams->m_pNodeNumCats[i] != m_pSearchParams->m_pNodeNumCats[0])
bEqualCategories = 0;
if(bEqualCategories) {
switch(maxParentSet) {
case 1: switch(maxCategories) {
case 2: pDagList = new DAGD_SEARCH<double, int, int, 1, 2>; break;
case 3: pDagList = new DAGD_SEARCH<double, int, int, 1, 3>; break;
case 4: pDagList = new DAGD_SEARCH<double, int, int, 1, 4>; break;
default: CATNET_NOTSUPP_ERR();break;
}
break;
case 2: switch(maxCategories) {
case 2: pDagList = new DAGD_SEARCH<double, int, int, 2, 2>; break;
case 3: pDagList = new DAGD_SEARCH<double, int, int, 2, 3>; break;
case 4: pDagList = new DAGD_SEARCH<double, int, int, 2, 4>; break;
default: CATNET_NOTSUPP_ERR();break;
}
break;
case 3: switch(maxCategories) {
case 2: pDagList = new DAGD_SEARCH<double, int, int, 3, 2>; break;
case 3: pDagList = new DAGD_SEARCH<double, int, int, 3, 3>; break;
case 4: pDagList = new DAGD_SEARCH<double, int, int, 3, 4>; break;
default: CATNET_NOTSUPP_ERR();break;
}
break;
case 4: switch(maxCategories) {
case 2: pDagList = new DAGD_SEARCH<double, int, int, 4, 2>; break;
case 3: pDagList = new DAGD_SEARCH<double, int, int, 4, 3>; break;
case 4: pDagList = new DAGD_SEARCH<double, int, int, 4, 4>; break;
default: CATNET_NOTSUPP_ERR();break;
}
break;
default: CATNET_NOTSUPP_ERR();break;
}
} /* bEqualCategories */
else {
switch(maxParentSet) {
case 1:
pDagList = new DAGD_SEARCH_DC<double, int, int, 1>; break;
case 2:
pDagList = new DAGD_SEARCH_DC<double, int, int, 2>; break;
case 3:
pDagList = new DAGD_SEARCH_DC<double, int, int, 3>; break;
case 4:
pDagList = new DAGD_SEARCH_DC<double, int, int, 4>; break;
default: CATNET_NOTSUPP_ERR();break;
}
} /* !bEqualCategories */
}
else /* !bIntSample */ {
pNodeOffsets = (int*)CATNET_MALLOC(m_numNodes*sizeof(int));
if (!pNodeOffsets) {
CATNET_MEM_ERR();
}
memset(pNodeOffsets, 0, m_numNodes*sizeof(int));
maxCategories = 0;
PROTECT(rNodeCats = AS_LIST(rNodeCats));
for(i = 0; i < m_numNodes; i++) {
//rnodecat = AS_INTEGER(VECTOR_ELT(rNodeCats, (int)(m_pRorder[i] - 1)));
rnodecat = AS_INTEGER(VECTOR_ELT(rNodeCats, i));
len = length(rnodecat);
if(maxCategories < len)
maxCategories = len;
//if(maxCategories > 0 && maxCategories != len)
// CATNET_ERR("Nodes should have equal number of categories");
pNodeOffsets[i] = len;
if(i > 0)
pNodeOffsets[i] = pNodeOffsets[i-1] + len;
if(isVector(rnodecat) && len > 0) {
m_pSearchParams->m_pNodeNumCats[i] = len;
m_pSearchParams->m_pNodeCats[i] = (int*)CATNET_MALLOC(len*sizeof(int));
if (m_pSearchParams->m_pNodeCats[i]) {
for(j = 0; j < len; j++)
m_pSearchParams->m_pNodeCats[i][j] = INTEGER(rnodecat)[j];
}
}
}
for(i = m_numNodes - 1; i > 0; i--)
pNodeOffsets[i] = pNodeOffsets[i-1];
pNodeOffsets[0] = 0;
UNPROTECT(1);
PROTECT(rSamples = AS_NUMERIC(rSamples));
pfSamples = (double*)m_pSearchParams->m_pSamples;
pfRsamples = REAL(rSamples);
int ii = 0;
if (pfSamples && pfRsamples) {
for(i = 0; i < m_numNodes; i++) {
for(j = 0; j < m_numSamples; j++) {
memcpy(pfSamples+j*sampleline + ii,
pfRsamples+j*sampleline + pNodeOffsets[m_pRorder[i] - 1],
m_pSearchParams->m_pNodeNumCats[i]*sizeof(double));
if(R_IsNA(pfSamples[j*sampleline + ii]) || pfSamples[j*sampleline + ii] < 0) {
pfSamples[j*sampleline + ii] = CATNET_NAN;
}
}
ii += m_pSearchParams->m_pNodeNumCats[i];
}
}
UNPROTECT(1); // rSamples
CATNET_FREE(pNodeOffsets);
pNodeOffsets = 0;
bEqualCategories = 1;
for(i = 0; i < m_numNodes; i++)
if(i > 1 && m_pSearchParams->m_pNodeNumCats[i] != m_pSearchParams->m_pNodeNumCats[0])
bEqualCategories = 0;
if(bEqualCategories) {
switch(maxParentSet) {
case 1: switch(maxCategories) {
case 2: pDagList = new DAGP_SEARCH<double, int, 1, 2>; break;
case 3: pDagList = new DAGP_SEARCH<double, int, 1, 3>; break;
case 4: pDagList = new DAGP_SEARCH<double, int, 1, 4>; break;
default: CATNET_NOTSUPP_ERR();break;
}
break;
case 2: switch(maxCategories) {
case 2: pDagList = new DAGP_SEARCH<double, int, 2, 2>; break;
case 3: pDagList = new DAGP_SEARCH<double, int, 2, 3>; break;
case 4: pDagList = new DAGP_SEARCH<double, int, 2, 4>; break;
default: CATNET_NOTSUPP_ERR();break;
}
break;
case 3: switch(maxCategories) {
case 2: pDagList = new DAGP_SEARCH<double, int, 3, 2>; break;
case 3: pDagList = new DAGP_SEARCH<double, int, 3, 3>; break;
case 4: pDagList = new DAGP_SEARCH<double, int, 3, 4>; break;
default: CATNET_NOTSUPP_ERR();break;
}
break;
case 4: switch(maxCategories) {
case 2: pDagList = new DAGP_SEARCH<double, int, 4, 2>; break;
case 3: pDagList = new DAGP_SEARCH<double, int, 4, 3>; break;
case 4: pDagList = new DAGP_SEARCH<double, int, 4, 4>; break;
default: CATNET_NOTSUPP_ERR();break;
}
break;
default: CATNET_NOTSUPP_ERR();break;
}
} /* bEqualCategories */
else {
switch(maxParentSet) {
case 1:
pDagList = new DAGP_SEARCH_DC<double, int, 1>; break;
case 2:
pDagList = new DAGP_SEARCH_DC<double, int, 2>; break;
case 3:
pDagList = new DAGP_SEARCH_DC<double, int, 3>; break;
case 4:
pDagList = new DAGP_SEARCH_DC<double, int, 4>; break;
default: CATNET_NOTSUPP_ERR();break;
}
} /* !bEqualCategories */
}
if(!pDagList)
CATNET_MEM_ERR();
pDagList->search(m_pSearchParams);
if(m_pSearchParams)
delete m_pSearchParams;
m_pSearchParams = 0;
if(!pDagList->m_dagPars || pDagList->m_numDags < 1) {
warning("No networks are found");
return R_NilValue;
}
int *pn;
SEXP plist, pint, ppars, pLoglik, pComplx;
SEXP daglist = PROTECT(NEW_OBJECT(MAKE_CLASS("dagEvaluate")));
PROTECT(pint = NEW_INTEGER(1));
INTEGER_POINTER(pint)[0] = m_numNodes;
SET_SLOT(daglist, install("numnodes"), pint);
UNPROTECT(1);
PROTECT(pint = NEW_INTEGER(1));
INTEGER_POINTER(pint)[0] = m_numSamples;
SET_SLOT(daglist, install("numsamples"), pint);
UNPROTECT(1);
PROTECT(pint = NEW_INTEGER(1));
INTEGER_POINTER(pint)[0] = maxCategories;
SET_SLOT(daglist, install("maxcats"), pint);
UNPROTECT(1);
PROTECT(pint = NEW_INTEGER(1));
INTEGER_POINTER(pint)[0] = maxParentSet;
SET_SLOT(daglist, install("maxpars"), pint);
UNPROTECT(1);
PROTECT(plist = allocVector(VECSXP, m_numNodes));
for(k = 0; k < m_numNodes; k++) {
node = m_pRorder[k]-1;
if(!pDagList->m_parSlots[k] || pDagList->m_numParSlots[k] <= 0) {
SET_VECTOR_ELT(plist, node, R_NilValue);
continue;
}
PROTECT(ppars = NEW_INTEGER(pDagList->m_numParSlots[k]/*maxParentSet*/*maxParentSet));
pn = INTEGER_POINTER(ppars);
for(j = 0; j < pDagList->m_numParSlots[k]/*maxParentSet*/; j++) {
i = 0;
while(i < maxParentSet && pDagList->m_parSlots[k][j*maxParentSet+i] >= 0) {
pn[j*maxParentSet+i] =
m_pRorder[pDagList->m_parSlots[k][j*maxParentSet+i]];
i++;
}
for(; i < maxParentSet; i++)
pn[j*maxParentSet+i] = 0;
}
SET_VECTOR_ELT(plist, node, ppars);
UNPROTECT(1);
}
SET_SLOT(daglist, install("parSlots"), plist);
UNPROTECT(1);
PROTECT(plist = allocVector(VECSXP, m_numNodes));
for(k = 0; k < m_numNodes; k++) {
node = m_pRorder[k]-1;
if(!pDagList->m_parLogliks[k] || pDagList->m_numParSlots[k] <= 0) {
SET_VECTOR_ELT(plist, node, R_NilValue);
continue;
}
PROTECT(ppars = NEW_NUMERIC(pDagList->m_numParSlots[k]));
memcpy(NUMERIC_POINTER(ppars), pDagList->m_parLogliks[k], pDagList->m_numParSlots[k]*sizeof(double));
SET_VECTOR_ELT(plist, node, ppars);
UNPROTECT(1);
}
SET_SLOT(daglist, install("parLogliks"), plist);
UNPROTECT(1);
PROTECT(plist = allocVector(VECSXP, m_numNodes));
for(k = 0; k < m_numNodes; k++) {
node = m_pRorder[k]-1;
if(!pDagList->m_parComplx[k] || pDagList->m_numParSlots[k] <= 0) {
SET_VECTOR_ELT(plist, node, R_NilValue);
continue;
}
PROTECT(ppars = NEW_INTEGER(pDagList->m_numParSlots[k]));
memcpy(INTEGER_POINTER(ppars), pDagList->m_parComplx[k], pDagList->m_numParSlots[k]*sizeof(int));
SET_VECTOR_ELT(plist, node, ppars);
UNPROTECT(1);
}
SET_SLOT(daglist, install("parComplx"), plist);
UNPROTECT(1);
PROTECT(plist = allocVector(VECSXP, m_numNodes));
for(k = 0; k < m_numNodes; k++) {
node = m_pRorder[k]-1;
if(!pDagList->m_parSampleSize[k] || pDagList->m_numParSlots[k] <= 0) {
SET_VECTOR_ELT(plist, node, R_NilValue);
continue;
}
PROTECT(ppars = NEW_INTEGER(pDagList->m_numParSlots[k]));
memcpy(INTEGER_POINTER(ppars), pDagList->m_parSampleSize[k], pDagList->m_numParSlots[k]*sizeof(int));
SET_VECTOR_ELT(plist, node, ppars);
UNPROTECT(1);
}
SET_SLOT(daglist, install("parSampleSize"), plist);
UNPROTECT(1);
PROTECT(pint = NEW_INTEGER(1));
INTEGER_POINTER(pint)[0] = pDagList->m_numDags;
SET_SLOT(daglist, install("numDags"), pint);
UNPROTECT(1);
PROTECT(plist = allocVector(VECSXP, pDagList->m_numDags));
PROTECT(pLoglik = NEW_NUMERIC(pDagList->m_numDags));
PROTECT(pComplx = NEW_INTEGER(pDagList->m_numDags));
DAG_PARS<double> *pDags = pDagList->m_dagPars;
char *pParBuff = (char*)CATNET_MALLOC((m_numNodes+1)*sizeof(int));
int *pIntBuff = (int*)CATNET_MALLOC((m_numNodes+1)*sizeof(int));
int nParBuff;
if (!pParBuff || !pIntBuff) {
CATNET_MEM_ERR();
}
for(k = 0; k < pDagList->m_numDags && pDags; k++) {
NUMERIC_POINTER(pLoglik)[k] = pDags->loglik;
INTEGER_POINTER(pComplx)[k] = pDags->complx;
if(pDags->numPars == 0) {
SET_VECTOR_ELT(plist, k, R_NilValue);
continue;
}
nParBuff = m_numNodes;
if(pDags->compressNumPars(pIntBuff, pParBuff, nParBuff, m_pRorder) <= 0) {
SET_VECTOR_ELT(plist, k, R_NilValue);
continue;
}
nParBuff = 1 + (int)((nParBuff*sizeof(char))/sizeof(int));
PROTECT(ppars = NEW_INTEGER(nParBuff));
memcpy(INTEGER_POINTER(ppars), pParBuff, nParBuff*sizeof(int));
SET_VECTOR_ELT(plist, k, ppars);
UNPROTECT(1);
pDags = pDags->next;
}
CATNET_FREE(pParBuff);
CATNET_FREE(pIntBuff);
SET_SLOT(daglist, install("numPars"), plist);
SET_SLOT(daglist, install("loglik"), pLoglik);
SET_SLOT(daglist, install("complx"), pComplx);
UNPROTECT(3);
UNPROTECT(1); // cnet
delete pDagList;
pDagList = 0;
if(m_pRorder)
CATNET_FREE(m_pRorder);
m_pRorder = 0;
return daglist;
}
SEXP do_dmeasure (SEXP object, SEXP y, SEXP x, SEXP times, SEXP params, SEXP log, SEXP gnsi)
{
int nprotect = 0;
pompfunmode mode = undef;
int give_log;
int ntimes, nvars, npars, ncovars, nreps, nrepsx, nrepsp, nobs;
SEXP Snames, Pnames, Cnames, Onames;
SEXP pompfun;
SEXP cvec, tvec = R_NilValue;
SEXP xvec = R_NilValue, yvec = R_NilValue, pvec = R_NilValue;
SEXP fn, ans, fcall, rho = R_NilValue;
SEXP F;
int *sidx = 0, *pidx = 0, *cidx = 0, *oidx = 0;
int *dim;
struct lookup_table covariate_table;
pomp_measure_model_density *ff = NULL;
PROTECT(times = AS_NUMERIC(times)); nprotect++;
ntimes = length(times);
if (ntimes < 1)
errorcall(R_NilValue,"in 'dmeasure': length('times') = 0, no work to do");
PROTECT(y = as_matrix(y)); nprotect++;
dim = INTEGER(GET_DIM(y));
nobs = dim[0];
if (ntimes != dim[1])
errorcall(R_NilValue,"in 'dmeasure': length of 'times' and 2nd dimension of 'y' do not agree");
PROTECT(x = as_state_array(x)); nprotect++;
dim = INTEGER(GET_DIM(x));
nvars = dim[0]; nrepsx = dim[1];
if (ntimes != dim[2])
errorcall(R_NilValue,"in 'dmeasure': length of 'times' and 3rd dimension of 'x' do not agree");
PROTECT(params = as_matrix(params)); nprotect++;
dim = INTEGER(GET_DIM(params));
npars = dim[0]; nrepsp = dim[1];
nreps = (nrepsp > nrepsx) ? nrepsp : nrepsx;
if ((nreps % nrepsp != 0) || (nreps % nrepsx != 0))
errorcall(R_NilValue,"in 'dmeasure': larger number of replicates is not a multiple of smaller");
PROTECT(Onames = GET_ROWNAMES(GET_DIMNAMES(y))); nprotect++;
PROTECT(Snames = GET_ROWNAMES(GET_DIMNAMES(x))); nprotect++;
PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++;
PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(GET_SLOT(object,install("covar"))))); nprotect++;
give_log = *(INTEGER(AS_INTEGER(log)));
// set up the covariate table
covariate_table = make_covariate_table(object,&ncovars);
// vector for interpolated covariates
PROTECT(cvec = NEW_NUMERIC(ncovars)); nprotect++;
SET_NAMES(cvec,Cnames);
// extract the user-defined function
PROTECT(pompfun = GET_SLOT(object,install("dmeasure"))); nprotect++;
PROTECT(fn = pomp_fun_handler(pompfun,gnsi,&mode)); nprotect++;
// extract 'userdata' as pairlist
PROTECT(fcall = VectorToPairList(GET_SLOT(object,install("userdata")))); nprotect++;
// first do setup
switch (mode) {
case Rfun: // R function
PROTECT(tvec = NEW_NUMERIC(1)); nprotect++;
PROTECT(xvec = NEW_NUMERIC(nvars)); nprotect++;
PROTECT(yvec = NEW_NUMERIC(nobs)); nprotect++;
PROTECT(pvec = NEW_NUMERIC(npars)); nprotect++;
SET_NAMES(xvec,Snames);
SET_NAMES(yvec,Onames);
SET_NAMES(pvec,Pnames);
// set up the function call
PROTECT(fcall = LCONS(cvec,fcall)); nprotect++;
SET_TAG(fcall,install("covars"));
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(tvec,fcall)); nprotect++;
SET_TAG(fcall,install("t"));
PROTECT(fcall = LCONS(xvec,fcall)); nprotect++;
SET_TAG(fcall,install("x"));
PROTECT(fcall = LCONS(yvec,fcall)); nprotect++;
SET_TAG(fcall,install("y"));
PROTECT(fcall = LCONS(fn,fcall)); nprotect++;
// get the function's environment
PROTECT(rho = (CLOENV(fn))); nprotect++;
break;
case native: // native code
// construct state, parameter, covariate, observable indices
oidx = INTEGER(PROTECT(name_index(Onames,pompfun,"obsnames","observables"))); nprotect++;
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);
break;
default:
errorcall(R_NilValue,"in 'dmeasure': unrecognized 'mode'"); // # nocov
break;
}
// create array to store results
{
int dim[2] = {nreps, ntimes};
const char *dimnm[2] = {"rep","time"};
PROTECT(F = makearray(2,dim)); nprotect++;
fixdimnames(F,dimnm,2);
}
// now do computations
switch (mode) {
case Rfun: // R function
{
int first = 1;
double *ys = REAL(y);
double *xs = REAL(x);
double *ps = REAL(params);
double *cp = REAL(cvec);
double *tp = REAL(tvec);
double *xp = REAL(xvec);
double *yp = REAL(yvec);
double *pp = REAL(pvec);
double *ft = REAL(F);
double *time = REAL(times);
int j, k;
for (k = 0; k < ntimes; k++, time++, ys += nobs) { // loop over times
R_CheckUserInterrupt(); // check for user interrupt
*tp = *time; // copy the time
table_lookup(&covariate_table,*time,cp); // interpolate the covariates
memcpy(yp,ys,nobs*sizeof(double));
for (j = 0; j < nreps; j++, ft++) { // loop over replicates
// copy the states and parameters into place
memcpy(xp,&xs[nvars*((j%nrepsx)+nrepsx*k)],nvars*sizeof(double));
memcpy(pp,&ps[npars*(j%nrepsp)],npars*sizeof(double));
if (first) {
// evaluate the call
PROTECT(ans = eval(fcall,rho)); nprotect++;
if (LENGTH(ans) != 1)
errorcall(R_NilValue,"in 'dmeasure': user 'dmeasure' returns a vector of length %d when it should return a scalar",LENGTH(ans));
*ft = *(REAL(AS_NUMERIC(ans)));
first = 0;
} else {
*ft = *(REAL(AS_NUMERIC(eval(fcall,rho))));
}
}
}
}
break;
case native: // native code
set_pomp_userdata(fcall);
{
double *yp = REAL(y);
double *xs = REAL(x);
double *ps = REAL(params);
double *cp = REAL(cvec);
double *ft = REAL(F);
double *time = REAL(times);
double *xp, *pp;
int j, k;
for (k = 0; k < ntimes; k++, time++, yp += nobs) { // loop over times
R_CheckUserInterrupt(); // check for user interrupt
// interpolate the covar functions for the covariates
table_lookup(&covariate_table,*time,cp);
for (j = 0; j < nreps; j++, ft++) { // loop over replicates
xp = &xs[nvars*((j%nrepsx)+nrepsx*k)];
pp = &ps[npars*(j%nrepsp)];
(*ff)(ft,yp,xp,pp,give_log,oidx,sidx,pidx,cidx,ncovars,cp,*time);
}
}
}
unset_pomp_userdata();
break;
default:
errorcall(R_NilValue,"in 'dmeasure': unrecognized 'mode'"); // # nocov
break;
}
UNPROTECT(nprotect);
return F;
}
/**********************************************************************
* C Code Documentation ************************************************
**********************************************************************
NAME time_sum
DESCRIPTION Sum a time span or time object.
To be called from R as
\\
{\tt
.Call("time_sum", time_vec, na_rm, cum)
}
where TIMECLASS is replaced by the name of the time or time
span class. Normally only time spans are summed, but a time
object can be summed to calculate mean.
ARGUMENTS
IARG time_vec The R time or time span vector object
IARG na_rm T to remove NAs
IARG cum T to do a cumulative sum vector, F for sum
RETURN If cum is T, na_rm is ignored and this function returns a
vector of the same type as the input whose elements are the
cumulative sum of the inputs through the corresponding input element.
If the jth element is NA, then all subsequent elements of the return
will be NA and a warning will be generated. If cum is F, this
function returns a length 1 vector of the same type as the input,
containing the sum of all the elements. If na_rm is False, any
NA in the input will generate an NA return value.
ALGORITHM The sums are calculated through addition, along with
the adjust_time or adjust_span function.
No special time zones or formats are put on the returned object.
EXCEPTIONR
NOTE
**********************************************************************/
SEXP time_sum( SEXP time_vec, SEXP na_rm, SEXP cum )
{
SEXP ret;
Sint *in_days, *in_ms, *out_days, *out_ms, *rm_na, *in_cum;
Sint i, lng, is_span, tmplng, tmp;
/* get the desired parts of the time object */
if( !time_get_pieces( time_vec, NULL, &in_days, &in_ms, &lng, NULL,
NULL, NULL ))
error( "Invalid time argument in C function time_sum" );
/* get na_rm and cum */
PROTECT(na_rm = AS_LOGICAL(na_rm));
if( length(na_rm) < 1L){
UNPROTECT(3);
error( "Problem extracting data from second argument in C function time_sum" );
}
rm_na = (Sint *) LOGICAL(na_rm);
PROTECT(cum = AS_LOGICAL(cum));
if( length(cum) < 1L){
UNPROTECT(4);
error( "Problem extracting data from third argument in C function time_sum" );
}
in_cum = (Sint *) LOGICAL(cum);
/* create output time or time span object */
is_span = 0;
if( checkClass( time_vec, IS_TIME_CLASS, 1L ))
PROTECT(ret = time_create_new( *in_cum ? lng : 1, &out_days, &out_ms ));
else if( checkClass( time_vec, IS_TSPAN_CLASS, 1L ))
{
is_span = 1;
PROTECT(ret = tspan_create_new( *in_cum ? lng : 1, &out_days, &out_ms ));
}
else{
UNPROTECT(4);
error( "Unknown class on first argument in C function time_sum" );
}
if( !out_days || !out_ms || !ret ){
UNPROTECT(5);
error( "Could not create return object in C function time_sum" );
}
out_days[0] = out_ms[0] = 0;
/* go through input and find sum */
for( i = 0; i < lng; i++ )
{
/* check for NA */
if( in_days[i] ==NA_INTEGER ||
in_ms[i] ==NA_INTEGER)
{
if( !*in_cum && *rm_na ) /* ignore NA */
continue;
else /* NA causes output to be NA */
{
if( *in_cum ) {
for( ; i < lng; i++ ) /* fill in all the rest */
{
out_days[i] = NA_INTEGER;
out_ms[i] = NA_INTEGER;
}
warning( "Found NA value in cumsum" );
}
else /* make the sum NA */
{
out_days[0] = NA_INTEGER;
out_ms[0] = NA_INTEGER;
}
UNPROTECT(5);
return( ret );
}
}
/* add this value in */
if( *in_cum && ( i >= 1 ))
{
out_days[i] = out_days[i-1] + in_days[i];
out_ms[i] = out_ms[i-1] + in_ms[i];
if( is_span )
tmp = adjust_span( &(out_days[i]), &(out_ms[i] ));
else
tmp = adjust_time( &(out_days[i]), &(out_ms[i] ));
} else {
out_days[0] += in_days[i];
out_ms[0] += in_ms[i];
if( is_span )
tmp = adjust_span( &(out_days[0]), &(out_ms[0] ));
else
tmp = adjust_time( &(out_days[0]), &(out_ms[0] ));
}
if( !tmp )
{
out_days[0] = NA_INTEGER;
out_ms[0] = NA_INTEGER;
}
}
UNPROTECT(5); //3+2 from time_get_pieces
return ret;
}
/**********************************************************************
* C Code Documentation ************************************************
**********************************************************************
NAME time_range
DESCRIPTION Find the range of a time or time span.
To be called from R as
\\
{\tt
.Call("time_range", time_vec, na_rm)
}
where TIMECLASS is replaced by the name of the time or time
span class.
ARGUMENTS
IARG time_vec The R time or time span vector object
IARG na_rm T to remove NAs
RETURN Returns a length 2 time or time span vector (same as passed
in class) containing the minimum and maximum times or time spans.
ALGORITHM If na_rm is False and there are NAs, this function will
return NA for the min and max. Otherwise, it will find the minimum
and maximum time or time span in the passed in vector, and return
them in a newly created time object.
No special time zones or formats are put on the returned object.
EXCEPTIONS
NOTE
**********************************************************************/
SEXP time_range( SEXP time_vec, SEXP na_rm )
{
SEXP ret;
Sint *in_days, *in_ms, *out_days, *out_ms, *rm_na;
Sint i, lng, initialized, tmplng;
/* get the desired parts of the time object */
if( !time_get_pieces( time_vec, NULL, &in_days, &in_ms, &lng, NULL,
NULL, NULL ))
error( "Invalid time argument in C function time_range" );
/* get na_rm */
PROTECT(na_rm = AS_LOGICAL(na_rm));
if( length(na_rm) < 1L){
UNPROTECT(3);
error( "Problem extracting data from second argument in C function time_range" );
}
rm_na = (Sint *) LOGICAL(na_rm);
/* create output time or time span object */
if( checkClass( time_vec, IS_TIME_CLASS, 1L ))
PROTECT(ret = time_create_new( 2, &out_days, &out_ms ));
else if( checkClass( time_vec, IS_TSPAN_CLASS, 1L ))
PROTECT(ret = tspan_create_new( 2, &out_days, &out_ms ));
else {
UNPROTECT(3);
error( "Unknown class on first argument in C function time_range" );
}
if( !out_days || !out_ms || !ret ){
UNPROTECT(4);
error( "Could not create return object in C function time_range" );
}
/* go through input and find_range */
initialized = 0;
for( i = 0; i < lng; i++ )
{
/* check for NA */
if( in_days[i] ==NA_INTEGER ||
in_ms[i] ==NA_INTEGER)
{
if( *rm_na ) /* ignore NA */
continue;
else /* NA causes output to be NA */
{
out_days[0] = NA_INTEGER;
out_ms[0] = NA_INTEGER;
out_days[1] = NA_INTEGER;
out_ms[1] = NA_INTEGER;
return( ret );
}
}
/* if we haven't put anything into return vector yet, put this value in */
if( !initialized )
{
out_days[0] = out_days[1] = in_days[i];
out_ms[0] = out_ms[1] = in_ms[i];
initialized = 1;
continue;
}
/* check to see if we're bigger or smaller than current max/min */
if(( in_days[i] > out_days[1] ) ||
(( in_days[i] == out_days[1] ) && ( in_ms[i] > out_ms[1] )))
{
out_days[1] = in_days[i];
out_ms[1] = in_ms[i];
}
if(( in_days[i] < out_days[0] ) ||
(( in_days[i] == out_days[0] ) && ( in_ms[i] < out_ms[0] )))
{
out_days[0] = in_days[i];
out_ms[0] = in_ms[i];
}
}
if( !initialized ) /* didn't find anything in the vector */
{
out_days[0] = NA_INTEGER;
out_ms[0] = NA_INTEGER;
out_days[1] = NA_INTEGER;
out_ms[1] = NA_INTEGER;
}
UNPROTECT(4); //2+2 from time_get_pieces
return ret;
}
SEXP time_rel_seq( SEXP start_time, SEXP end_time,
SEXP len_vec, SEXP has_len,
SEXP rel_strs, SEXP hol_vec,
SEXP zone_list)
{
SEXP ret, tmp_days, tmp_ms;
Sint *start_days, *start_ms, *end_days, *end_ms,
*out_days, *out_ms, *use_len, *seq_len;
Sint *hol_days, *hol_ms, num_alloc;
Sint i, lng_hol, lng, direction=0;
TIME_DATE_STRUCT td, td_hol;
TZONE_STRUCT *tzone, *tzone_hol;
char *in_strs;
Sint *hol_dates;
Sint pre_start_day, pre_start_ms, used_old_alg ;
Sint num_protect=0;
/* figure out if we have end time or length */
PROTECT(has_len = AS_LOGICAL(has_len));
num_protect++;
if( length(has_len) < 1L){
UNPROTECT(num_protect);
error( "Problem extracting data from second argument in C function time_rel_seq" );
}
use_len = (Sint *) LOGICAL(has_len);
/* get the desired parts of the time objects */
if( !time_get_pieces( start_time, NULL, &start_days, &start_ms, &lng, NULL,
&td.zone, NULL ) ||
!td.zone || !lng || !start_days || !start_ms ){
UNPROTECT(num_protect);
error( "Invalid time argument in C function time_rel_seq" );
}
num_protect += 2; //from time_get_pieces
if( lng > 1 )
warning( "Start time has multiple elements; only the first will be used" );
tzone = find_zone( td.zone, zone_list );
if( !tzone ){
UNPROTECT(num_protect);
error( "Unknown or unreadable time zone in C function time_rel_seq" );
}
if( !(*use_len))
{
if( !time_get_pieces( end_time, NULL, &end_days, &end_ms,
&lng, NULL, NULL, NULL ) ||
!lng || !end_days || !end_ms ){
error( "Invalid time argument in C function time_rel_seq" );
UNPROTECT(num_protect);
}
num_protect +=2;
if( lng > 1 )
warning( "End time has multiple elements; only the first will be used" );
}
if( !time_get_pieces( hol_vec, NULL, &hol_days, &hol_ms, &lng_hol, NULL,
&td_hol.zone, NULL ) ||
(( lng_hol && (!hol_days || !hol_ms )) || !td_hol.zone )){
UNPROTECT(num_protect);
error( "Invalid holiday argument in C function time_rel_seq" );
}
num_protect +=2;
tzone_hol = find_zone( td_hol.zone, zone_list );
if( !tzone_hol ){
UNPROTECT(num_protect);
error( "Unknown or unreadable time zone for holidays in C function time_rel_seq" );
}
/* extract the rel time string */
if(!isString(rel_strs) || (lng = length(rel_strs)) < 1L){
UNPROTECT(num_protect);
error( "Problem extracting relative time strings in C function time_rel_seq" );
}
if( lng > 1 )
warning( "Relative time has multiple elements; only the first will be used" );
in_strs = (char *) CHAR(STRING_ELT(rel_strs, 0));
/* extract the length */
if( *use_len )
{
if( !IS_INTEGER(len_vec) || (lng = length(len_vec)) < 1L){
UNPROTECT(num_protect);
error( "Problem extracting data from third argument in C function time_rel_seq" );
}
seq_len = INTEGER(len_vec);
if( *seq_len < 0 )
error( "Length cannot be less than zero" );
if( lng > 1 )
warning( "Length has multiple elements; only the first will be used" );
}
/* get list of holiday dates */
hol_dates = NULL;
if( lng_hol )
{
hol_dates = (Sint *) R_alloc( lng_hol, sizeof(Sint) );
for( i = 0; i < lng_hol; i++ )
{
if( hol_days[i] ==NA_INTEGER ||
hol_ms[i] ==NA_INTEGER ||
!jms_to_struct( hol_days[i], hol_ms[i], &td_hol ) ||
!GMT_to_zone( &td_hol, tzone_hol ) ||
!julian_from_mdy( td_hol, &(hol_dates[i])))
error( "Bad holiday data in C function time_rel_seq" );
}
}
/* create output time object or temporary storage */
if( *use_len )
{
if( *seq_len ==NA_INTEGER){
UNPROTECT(num_protect);
error( "NA not allowed in sequence" );
}
PROTECT(ret = time_create_new( *seq_len, &out_days, &out_ms ));
num_protect++;
if( !out_days || !out_ms || !ret ){
UNPROTECT(num_protect);
error( "Could not create return object in C function time_rel_seq" );
}
if(*seq_len == 0){
UNPROTECT(num_protect);
return ret;
}
} else
{
/* figure out the direction */
if( *end_days ==NA_INTEGER || *end_ms ==NA_INTEGER){
UNPROTECT(num_protect);
error( "NA not allowed in sequence" );
}
if(( *start_days > *end_days ) ||
(( *start_days == *end_days ) && ( *start_ms > *end_ms )))
direction = -1;
else if(( *end_days > *start_days ) ||
(( *start_days == *end_days ) && ( *end_ms > *start_ms )))
direction = 1;
else
direction = 0; /* this will be a flag to end after copying in start */
/* we don't know the length we'll need. Allocate at least 100,
and assume daily to figure out approx length if longer */
num_alloc = 100;
if( *start_days - *end_days > 100 )
num_alloc = *start_days - *end_days + 20;
if( *end_days - *start_days > 100 )
num_alloc = *end_days - *start_days + 20;
PROTECT(tmp_days = NEW_INTEGER(num_alloc));
PROTECT(tmp_ms = NEW_INTEGER(num_alloc));
num_protect += 2;
out_days = INTEGER(tmp_days);
out_ms = INTEGER(tmp_ms);
}
/* start with the start time */
if( *start_days ==NA_INTEGER || *start_ms ==NA_INTEGER){
UNPROTECT(num_protect);
error( "NA not allowed in sequence" );
}
/* fprintf(stderr, " time_rel_seq: start=%ld,%ld, in_strs[0]=%s\n", *start_days, *start_ms, in_strs[0]); */
if (avoid_bad_start_day) {
/* the following is gross. -wwd */
char tmp_strs[100] ;
strncpy(tmp_strs, in_strs, 99);
if (tmp_strs[0] == '-')
tmp_strs[0] = '+';
else if (tmp_strs[0] == '+')
tmp_strs[0] = '-';
if (tmp_strs[1] == 'a') {
/* fprintf(stderr, " time_rel_seq: alignment might have caused problems -- using old algorithm\n"); */
out_days[0] = *start_days;
out_ms[0] = *start_ms;
used_old_alg = 1 ;
i = 1 ;
} else {
/* convert to local zone, add, and convert back */
if( !jms_to_struct( *start_days, *start_ms, &td ) ||
!rtime_add_with_zones( &td, tmp_strs, hol_dates, lng_hol, tzone ) ||
!julian_from_mdy( td, &pre_start_day) ||
!ms_from_hms( td, &pre_start_ms)){
UNPROTECT(num_protect);
error( "Could not subtract relative time in C function time_rel_seq" );
}
/* fprintf(stderr, "pre_start=%ld,%ld\n", pre_start_day, pre_start_ms); */
i = 0; /* was i=1 */
used_old_alg = 0 ;
}
} else {
/* original algorithm */
out_days[0] = *start_days;
out_ms[0] = *start_ms;
i = 1 ;
used_old_alg = 1 ;
}
/* go through input and perform operation */
#define PREV_DAY ( (i>0) ? out_days[i-1] : pre_start_day )
#define PREV_MS ( (i>0) ? out_ms[i-1] : pre_start_ms )
/*LINTED: Const meant to be in cond context here */
while( 1 )
{
/* see if we are done */
if( *use_len && ( i >= *seq_len )){
UNPROTECT(num_protect);
return ret;
}
if( !*use_len )
{
if( !direction )
break;
if(( direction * ( PREV_DAY - *end_days ) > 0 ) ||
(( PREV_DAY == *end_days ) &&
( direction * ( PREV_MS - *end_ms ) > 0 )))
{
if (i>0) /* is i==0 possible? I think it means an error */
i--;
break;
}
/* also check on our allocation */
if( i >= num_alloc - 1 )
{
num_alloc += 200;
SETLENGTH( tmp_days, num_alloc );
out_days = INTEGER(tmp_days) ;
SETLENGTH( tmp_ms, num_alloc );
out_ms = INTEGER(tmp_ms) ;
}
}
/* convert to local zone, add, and convert back */
if( !jms_to_struct( PREV_DAY, PREV_MS, &td ) ||
!rtime_add_with_zones( &td, in_strs, hol_dates, lng_hol, tzone ) ||
!julian_from_mdy( td, &(out_days[i] )) ||
!ms_from_hms( td, &(out_ms[i] ))){
UNPROTECT(num_protect);
error( "Could not add relative time in C function time_rel_seq" );
}
/* make sure we went in the right direction */
if(( out_days[i] == PREV_DAY ) &&
( out_ms[i] == PREV_MS )){
UNPROTECT(num_protect);
error( "Relative date addition resulted in stationary time" );
}
if( !direction )
{
if(( out_days[i] > PREV_DAY ) ||
(( out_days[i] == PREV_DAY ) &&
( out_ms[i] > PREV_MS )))
direction = 1;
else
direction = -1;
} else
{
if(( direction * ( out_days[i] - PREV_DAY ) < 0 ) ||
(( out_days[i] == PREV_DAY ) &&
( direction * ( out_ms[i] - PREV_MS) < 0 ))){
UNPROTECT(num_protect);
error( "Relative date addition resulted in non-monotonic sequence" );
}
}
i++;
}
/* if we got here, it means we have to make a time object and
copy in the numbers now */
num_alloc = i;
PROTECT(ret = time_create_new( num_alloc, &end_days, &end_ms ));
num_protect++;
if( !end_days || !end_ms || !ret ){
UNPROTECT(num_protect);
error( "Could not create return object in C function time_rel_seq" );
}
for( i = 0; i < num_alloc; i++ )
{
end_days[i] = out_days[i];
end_ms[i] = out_ms[i];
}
UNPROTECT(num_protect);
return ret;
}
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;
}
