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