/** * Finds the minimum value in a list. * * @param args list of args * @param c number of args * @returns min number in list */ LuciObject *luci_min(LuciObject **args, unsigned int c) { if (c < 1) { LUCI_DIE("%s", "Missing parameter to min()\n"); } LuciObject *list = args[0]; if (!list || (!ISTYPE(list, obj_list_t))) { LUCI_DIE("%s", "Must specify a list to calculate min\n"); } LuciObject *item; double min = 0; unsigned int i, found_float = 0; for (i = 0; i < AS_LIST(list)->count; i ++) { item = AS_LIST(list)->items[i]; if (!item) { LUCI_DIE("%s", "Can't calulate max of list containing NULL value\n"); } if (ISTYPE(item, obj_int_t)) { if (i == 0) { min = (double)AS_INT(item)->i; } else if ( (double)AS_INT(item)->i < min) { min = (double)AS_INT(item)->i; } } else if (ISTYPE(item, obj_float_t)) { found_float = 1; if (i == 0) { min = AS_FLOAT(item)->f; } else if (AS_FLOAT(item)->f < min) { min = AS_FLOAT(item)->f; } } else { LUCI_DIE("Can't find min of list containing an object of type %s\n", item->type->type_name); } } LuciObject *ret; if (!found_float) { ret = LuciInt_new((long)min); } else { ret = LuciFloat_new(min); } return ret; }
/** * Asserts that a given LuciObject is equivalent to a boolean True * * Currently uses C @code assert @endcode , which will exit a program * mid-execution if the assertion fails. * * @param args list of args * @param c number of args * @returns LuciNilObj */ LuciObject *luci_assert(LuciObject **args, unsigned int c) { if (c < 1) { LUCI_DIE("%s", "Missing condition parameter to assert()\n"); } LuciObject *item = args[0]; if (ISTYPE(item, obj_int_t) && !AS_INT(item)->i) { LUCI_DIE("%s\n", "Assertion failed"); } else if (ISTYPE(item, obj_float_t) && !((long)AS_FLOAT(item)->f)) { LUCI_DIE("%s\n", "Float assertion failed"); } else if (ISTYPE(item, obj_string_t)) { if (strcmp("", AS_STRING(item)->s) == 0) { LUCI_DIE("%s\n", "String assertion failed"); } } else if (ISTYPE(item, obj_list_t) && (AS_LIST(item)->count == 0)) { LUCI_DIE("%s\n", "List assertion failed"); } else if (ISTYPE(item, obj_map_t) && (AS_MAP(item)->count == 0)) { LUCI_DIE("%s\n", "Map assertion failed"); } else if (ISTYPE(item, obj_file_t) && (AS_FILE(item)->ptr)) { LUCI_DIE("%s\n", "File assertion failed"); } return LuciNilObj; }
void CRF::Set_Data(SEXP _newcrf) { _crf = _newcrf; PROTECT(_nNodes = AS_INTEGER(GetVar(_crf, "n.nodes"))); PROTECT(_nEdges = AS_INTEGER(GetVar(_crf, "n.edges"))); PROTECT(_edges = AS_INTEGER(GetVar(_crf, "edges"))); PROTECT(_nStates = AS_INTEGER(GetVar(_crf, "n.states"))); PROTECT(_maxState = AS_INTEGER(GetVar(_crf, "max.state"))); nNodes = INTEGER_POINTER(_nNodes)[0]; nEdges = INTEGER_POINTER(_nEdges)[0]; edges = INTEGER_POINTER(_edges); nStates = INTEGER_POINTER(_nStates); maxState = INTEGER_POINTER(_maxState)[0]; PROTECT(_nAdj = AS_INTEGER(GetVar(_crf, "n.adj"))); PROTECT(_adjNodes = AS_LIST(GetVar(_crf, "adj.nodes"))); PROTECT(_adjEdges = AS_LIST(GetVar(_crf, "adj.edges"))); nAdj = INTEGER_POINTER(_nAdj); adjNodes = (int **) R_alloc(nNodes, sizeof(int *)); adjEdges = (int **) R_alloc(nNodes, sizeof(int *)); SEXP _temp; for (int i = 0; i < nNodes; i++) { SET_VECTOR_ELT(_adjNodes, i, _temp = AS_INTEGER(VECTOR_ELT(_adjNodes, i))); adjNodes[i] = INTEGER_POINTER(_temp); SET_VECTOR_ELT(_adjEdges, i, _temp = AS_INTEGER(VECTOR_ELT(_adjEdges, i))); adjEdges[i] = INTEGER_POINTER(_temp); } PROTECT(_nodePot = AS_NUMERIC(GetVar(_crf, "node.pot"))); PROTECT(_edgePot = AS_LIST(GetVar(_crf, "edge.pot"))); nodePot = NUMERIC_POINTER(_nodePot); edgePot = (double **) R_alloc(nEdges, sizeof(double *)); nEdgeStates = (int *) R_alloc(nEdges, sizeof(int)); for (int i = 0; i < nEdges; i++) { SET_VECTOR_ELT(_edgePot, i, _temp = AS_NUMERIC(VECTOR_ELT(_edgePot, i))); edgePot[i] = NUMERIC_POINTER(_temp); nEdgeStates[i] = nStates[EdgesBegin(i)] * nStates[EdgesEnd(i)]; } numProtect = 10; }
/** * Returns a boolean representation of a LuciIteratorObj * * @param o LuciIteratorObj * @returns true if the iterator can continue to iterate */ LuciObject* LuciIterator_asbool(LuciObject *o) { LuciObject *res = LuciNilObj; LuciObject *container = AS_ITERATOR(o)->container; unsigned int len = 0; if (ISTYPE(container, obj_list_t)) { len = AS_LIST(container)->count; } else if (ISTYPE(container, obj_map_t)) { len = AS_LIST(container)->size; } if (AS_INT(AS_ITERATOR(o)->idx)->i < len) { res = LuciInt_new(true); } else { res = LuciInt_new(false); } return res; }
/** * Computes the sum of a range of numbers. * * @param args list of args * @param c number of args * @returns sum of numbers */ LuciObject * luci_sum(LuciObject **args, unsigned int c) { if (c < 1) { LUCI_DIE("%s", "Missing parameter to sum()\n"); } LuciObject *list = args[0]; if (!list || (!ISTYPE(list, obj_list_t))) { LUCI_DIE("%s", "Must specify a list to calculate sum\n"); } LuciObject *item; double sum = 0; unsigned int i, found_float = 0; for (i = 0; i < AS_LIST(list)->count; i++) { item = AS_LIST(list)->items[i]; if (!item) { LUCI_DIE("%s", "Can't calulate sum of list containing NULL value\n"); } if (ISTYPE(item, obj_int_t)) { sum += (double)AS_INT(item)->i; } else if (ISTYPE(item, obj_float_t)) { found_float = 1; sum += AS_FLOAT(item)->f; } else { LUCI_DIE("%s", "Can't calculate sum of list containing non-numeric value\n"); } } LuciObject *ret; if (!found_float) { ret = LuciInt_new((long)sum); } else { ret = LuciFloat_new(sum); } return ret; }
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; }
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; }
/* Susceptible-Infectious-Removed MCMC analysis: . Exponentially distributed infectiousness periods */ SEXP expMH_SIR(SEXP N, SEXP removalTimes, SEXP otherParameters, SEXP priorValues, SEXP initialValues, SEXP bayesReps, SEXP bayesStart, SEXP bayesThin, SEXP bayesOut){ /* Declarations */ int ii, jj, kk, ll, nInfected, nRemoved, nProtected=0, initialInfected; SEXP infRateSIR, remRateSIR, logLikelihood;/*, timeInfected, timeDim, initialInf ; */ SEXP parameters, infectionTimes, candidateTimes, infectedBeforeDay; SEXP allTimes, indicator, SS, II; double infRate, remRate, oldLkhood, newLkhood, minimumLikelyInfectionTime; /* starting values */ double infRatePrior[2], remRatePrior[2], thetaprior; /* priors values */ double sumSI, sumDurationInfectious, likelihood,logR; int acceptRate=0, consistent=0, verbose, missingInfectionTimes; SEXP retParameters, parNames, acceptanceRate; SEXP infTimes; /* Code */ GetRNGstate(); /* should be before a call to a random number generator */ initialInfected = INTEGER(getListElement(otherParameters, "initialInfected"))[0]; verbose = INTEGER(getListElement(otherParameters, "verbose"))[0]; missingInfectionTimes = INTEGER(getListElement(otherParameters, "missingInfectionTimes"))[0]; PROTECT(N = AS_INTEGER(N)); ++nProtected; PROTECT(removalTimes = AS_NUMERIC(removalTimes)); ++nProtected; /* priors and starting values */ PROTECT(priorValues = AS_LIST(priorValues)); ++nProtected; PROTECT(initialValues = AS_LIST(initialValues)); ++nProtected; nRemoved = LENGTH(removalTimes); /* number of individuals removed */ /* bayes replications, thin, etc */ PROTECT(bayesReps = AS_INTEGER(bayesReps)); ++nProtected; PROTECT(bayesStart = AS_INTEGER(bayesStart)); ++nProtected; PROTECT(bayesThin = AS_INTEGER(bayesThin)); ++nProtected; PROTECT(bayesOut = AS_INTEGER(bayesOut)); ++nProtected; PROTECT(infRateSIR = allocVector(REALSXP, INTEGER(bayesOut)[0])); ++nProtected; PROTECT(remRateSIR = allocVector(REALSXP, INTEGER(bayesOut)[0])); ++nProtected; PROTECT(logLikelihood = allocVector(REALSXP, INTEGER(bayesOut)[0])); ++nProtected; /* PROTECT(timeInfected = allocVector(REALSXP, nRemoved * INTEGER(bayesOut)[0])); ++nProtected; PROTECT(timeDim = allocVector(INTSXP, 2)); ++nProtected; INTEGER(timeDim)[0] = nRemoved; INTEGER(timeDim)[1] = INTEGER(bayesOut)[0]; setAttrib(timeInfected, R_DimSymbol, timeDim); PROTECT(initialInf = allocVector(REALSXP, INTEGER(bayesOut)[0])); ++nProtected; */ PROTECT(parameters = allocVector(REALSXP,2)); ++nProtected; PROTECT(infectionTimes = allocVector(REALSXP,nRemoved)); ++nProtected; PROTECT(candidateTimes = allocVector(REALSXP,nRemoved)); ++nProtected; PROTECT(infectedBeforeDay = allocVector(REALSXP,nRemoved)); ++nProtected; PROTECT(infTimes = allocVector(REALSXP,nRemoved)); ++nProtected; for(jj = 0; jj < nRemoved; ++jj){ REAL(infectionTimes)[jj] = REAL(getListElement(initialValues, "infectionTimes"))[jj]; REAL(candidateTimes)[jj] = REAL(infectionTimes)[jj]; REAL(infectedBeforeDay)[jj] = REAL(getListElement(otherParameters, "infectedBeforeDay"))[jj]; REAL(infTimes)[jj] = 0; } nInfected = LENGTH(infectionTimes); PROTECT(allTimes = allocVector(REALSXP,nRemoved+nInfected)); ++nProtected; PROTECT(indicator = allocVector(INTSXP,nRemoved+nInfected)); ++nProtected; PROTECT(SS = allocVector(INTSXP,nRemoved+nInfected+1)); ++nProtected; PROTECT(II = allocVector(INTSXP,nRemoved+nInfected+1)); ++nProtected; /* working variables */ infRate = REAL(getListElement(initialValues, "infectionRate"))[0]; remRate = REAL(getListElement(initialValues, "removalRate"))[0]; minimumLikelyInfectionTime = REAL(getListElement(otherParameters, "minimumLikelyInfectionTime"))[0]; for(ii = 0; ii < 2; ++ii){ infRatePrior[ii] = REAL(getListElement(priorValues, "infectionRate"))[ii]; remRatePrior[ii] = REAL(getListElement(priorValues, "removalRate"))[ii]; } thetaprior = REAL(getListElement(priorValues, "theta"))[0]; REAL(parameters)[0] = infRate; REAL(parameters)[1] = remRate; expLikelihood_SIR(REAL(parameters),REAL(infectionTimes), REAL(removalTimes), &INTEGER(N)[0], &nInfected, &nRemoved, &sumSI, &sumDurationInfectious, &likelihood, REAL(allTimes),INTEGER(indicator),INTEGER(SS),INTEGER(II)); oldLkhood = likelihood; for(ii = 1; ii <= INTEGER(bayesReps)[0]; ++ii){ infRate = rgamma(nInfected-1+infRatePrior[0],1/(sumSI+infRatePrior[1])); /* update infRate */ remRate = rgamma(nRemoved+remRatePrior[0],1/(sumDurationInfectious+remRatePrior[1]));/*remRate */ /*Rprintf("SI = %f : I = %f\n",sumSI,sumDurationInfectious);*/ REAL(parameters)[0] = infRate; REAL(parameters)[1] = remRate; if(missingInfectionTimes){ expLikelihood_SIR(REAL(parameters),REAL(infectionTimes), REAL(removalTimes), &INTEGER(N)[0], &nInfected, &nRemoved, &sumSI, &sumDurationInfectious, &likelihood, REAL(allTimes),INTEGER(indicator),INTEGER(SS),INTEGER(II)); oldLkhood = likelihood; kk = ceil(unif_rand()*(nRemoved-1)); /* initial infection time excluded */ consistent=0; if(kk == nRemoved-1){ REAL(candidateTimes)[kk] = runif(REAL(infectionTimes)[kk-1], REAL(infectedBeforeDay)[kk]);} else if((REAL(infectionTimes)[kk+1] > REAL(infectedBeforeDay)[kk])){ REAL(candidateTimes)[kk] = runif(REAL(infectionTimes)[kk-1], REAL(infectedBeforeDay)[kk]);} else{REAL(candidateTimes)[kk] = runif(REAL(infectionTimes)[kk-1], REAL(infectionTimes)[kk+1]);} expLikelihood_SIR(REAL(parameters),REAL(candidateTimes), REAL(removalTimes), &INTEGER(N)[0], &nInfected, &nRemoved, &sumSI, &sumDurationInfectious, &likelihood, REAL(allTimes),INTEGER(indicator),INTEGER(SS),INTEGER(II)); newLkhood = likelihood; logR = (newLkhood-oldLkhood); if(log(unif_rand()) <= logR){ REAL(infectionTimes)[kk] = REAL(candidateTimes)[kk]; ++acceptRate; } REAL(candidateTimes)[kk] = REAL(infectionTimes)[kk];/* update candidate times */ REAL(infectionTimes)[0] = REAL(infectionTimes)[1] -rexp(1/(infRate*INTEGER(N)[0]+remRate+thetaprior)); REAL(candidateTimes)[0] = REAL(infectionTimes)[0]; } expLikelihood_SIR(REAL(parameters),REAL(infectionTimes), REAL(removalTimes), &INTEGER(N)[0], &nInfected, &nRemoved, &sumSI, &sumDurationInfectious, &likelihood, REAL(allTimes),INTEGER(indicator),INTEGER(SS),INTEGER(II)); oldLkhood = likelihood; kk = ceil(INTEGER(bayesReps)[0]/100); ll = ceil(INTEGER(bayesReps)[0]/ 10); if(verbose == 1){ if((ii % kk) == 0){Rprintf(".");} if((ii % ll) == 0){Rprintf(" %d\n",ii);} } if((ii >= (INTEGER(bayesStart)[0])) && ((ii-INTEGER(bayesStart)[0]) % INTEGER(bayesThin)[0] == 0)){ ll = (ii - (INTEGER(bayesStart)[0]))/INTEGER(bayesThin)[0]; /* REAL(initialInf)[ll] = REAL(infectionTimes)[0]; */ REAL(logLikelihood)[ll] = likelihood; REAL(infRateSIR)[ll] = infRate; REAL(remRateSIR)[ll] = remRate; for(jj = 0; jj < nRemoved; ++jj){ REAL(infTimes)[jj] += REAL(infectionTimes)[jj]; } /* for(jj = 0; jj < nRemoved; ++jj){ REAL(timeInfected)[(nRemoved*ll+jj)] = REAL(infectionTimes)[jj]; } */ } } PutRNGstate(); /* after using random number generators. */ /* Print infection times and removal times at last iteration */ for(jj = 0; jj < nRemoved; ++jj){ REAL(infTimes)[jj] = REAL(infTimes)[jj]/INTEGER(bayesOut)[0]; } if(verbose){ for(jj = 0; jj < nRemoved; ++jj){ Rprintf("%2d %8.4f %2.0f\n",jj, REAL(infTimes)[jj],REAL(removalTimes)[jj]); } } PROTECT(retParameters = NEW_LIST(5)); ++nProtected; PROTECT(acceptanceRate = allocVector(INTSXP,1)); ++nProtected; INTEGER(acceptanceRate)[0] = acceptRate; PROTECT(parNames = allocVector(STRSXP,5)); ++nProtected; SET_STRING_ELT(parNames, 0, mkChar("logLikelihood")); SET_STRING_ELT(parNames, 1, mkChar("infRateSIR")); SET_STRING_ELT(parNames, 2, mkChar("remRateSIR")); SET_STRING_ELT(parNames, 3, mkChar("infectionTimes")); SET_STRING_ELT(parNames, 4, mkChar("acceptanceRate")); setAttrib(retParameters, R_NamesSymbol,parNames); SET_ELEMENT(retParameters, 0, logLikelihood); SET_ELEMENT(retParameters, 1, infRateSIR); SET_ELEMENT(retParameters, 2, remRateSIR); SET_ELEMENT(retParameters, 3, infTimes); SET_ELEMENT(retParameters, 4, acceptanceRate); /* SET_ELEMENT(retParameters, 3, initialInf); SET_ELEMENT(retParameters, 4, timeInfected); */ UNPROTECT(nProtected); return(retParameters); }
SEXP R_THD_load_dset(SEXP Sfname, SEXP Opts) { SEXP Rdset, brik, head, names, opt, node_list=R_NilValue; int i=0, ip=0, sb, cnt=0, *iv=NULL, kparts=2; char *fname = NULL, *head_str; NI_group *ngr=NULL; NI_element *nel=NULL; char *listels[3] = {"head","brk","index_list"}; /* the brk is on purpose for backward compatibility */ double *dv=NULL; float *fv=NULL; THD_3dim_dataset *dset = NULL; int debug=0; if (!debug) debug = get_odebug(); /* get the options list, maybe */ PROTECT(Opts = AS_LIST(Opts)); if ((opt = getListElement(Opts,"debug")) != R_NilValue) { debug = (int)INTEGER_VALUE(opt); if (debug>2) set_odebug(debug); if (debug>1) INFO_message("Debug is %d\n", debug); } /* get the filename */ PROTECT(Sfname = AS_CHARACTER(Sfname)); fname = R_alloc(strlen(CHAR(STRING_ELT(Sfname,0)))+1, sizeof(char)); strcpy(fname, CHAR(STRING_ELT(Sfname,0))); /* open dset */ dset = THD_open_dataset(fname); if (dset) { if (debug > 1) INFO_message("Dset %s was loaded 2\n", fname); } else { ERROR_message("Dset %s could not be loaded\n", fname); UNPROTECT(2); return(R_NilValue); } /* form one long header string */ ngr = THD_nimlize_dsetatr(dset); PROTECT(head = allocVector(STRSXP, ngr->part_num)); for (ip=0,i=0; i<ngr->part_num; ++i) { switch( ngr->part_typ[i] ){ /*-- a sub-group ==> recursion! --*/ case NI_GROUP_TYPE: break ; case NI_ELEMENT_TYPE: nel = (NI_element *)ngr->part[i] ; head_str = NI_write_element_tostring(nel); if (debug > 1) fprintf(stderr,"%s\n", head_str); SET_STRING_ELT(head, ip, mkChar(head_str)); ++ip; free(head_str); break; default: break; } } NI_free_element(ngr); if (debug > 1) fprintf(stderr,"Forming data array of %d elements\n", DSET_NVOX(dset)*DSET_NVALS(dset)); /* form one long array of data */ PROTECT(brik = NEW_NUMERIC(DSET_NVOX(dset)*DSET_NVALS(dset))); dv = NUMERIC_POINTER(brik); EDIT_floatize_dataset(dset); for (cnt=0, sb=0; sb<DSET_NVALS(dset); ++sb) { if (!(fv = (float *)DSET_BRICK_ARRAY(dset,sb))) { ERROR_message("NULL brick array %d!\n", sb); UNPROTECT(4); return(R_NilValue); } if (debug > 1) fprintf(stderr,"Filling sb %d\n", sb); for (i=0; i<DSET_NVOX(dset); ++i) { dv[cnt++] = fv[i]; if (debug > 1) { if (debug > 2 || i<10) { fprintf(stderr,"%f\t", fv[i]); } } } if (debug == 2) fprintf(stderr,"...\n"); else if (debug > 2) fprintf(stderr,"\n"); } /* how about an index list ? */ if (dset->dblk->nnodes && dset->dblk->node_list) { if (debug > 1) fprintf(stderr,"Copying %d node indices\n", dset->dblk->nnodes); PROTECT(node_list = NEW_INTEGER(dset->dblk->nnodes)); iv = INTEGER_POINTER(node_list); memcpy(iv, dset->dblk->node_list, dset->dblk->nnodes*sizeof(int)); kparts = 3; } else { kparts = 2; if (debug > 1) fprintf(stderr,"No node indices %d %p\n", dset->dblk->nnodes, dset->dblk->node_list); } /* done with dset, dump it */ DSET_delete(dset); /* form output list */ PROTECT(names = allocVector(STRSXP,kparts)); for (i=0; i<kparts; ++i) { SET_STRING_ELT(names, i, mkChar(listels[i])); } PROTECT(Rdset = allocVector(VECSXP,kparts)); SET_VECTOR_ELT(Rdset, 0, head); SET_VECTOR_ELT(Rdset, 1, brik); if (node_list != R_NilValue) SET_VECTOR_ELT(Rdset, 2, node_list); setAttrib(Rdset, R_NamesSymbol, names); if (debug > 1) fprintf(stderr,"Unprotecting...\n"); if (kparts==3) UNPROTECT(7); else UNPROTECT(6); return(Rdset); }
SEXP R_THD_write_dset(SEXP Sfname, SEXP Sdset, SEXP Opts) { SEXP Rdset, brik, head, names, opt, node_list; int i=0, ip=0, sb, cnt=0, scale = 1, overwrite=0, addFDR=0, kparts=2, *iv=NULL; char *fname = NULL, *head_str, *stmp=NULL, *hist=NULL; NI_group *ngr=NULL; NI_element *nel=NULL; char *listels[3] = {"head","brk","index_list"}; /* the brk is on purpose for backward compatibility */ double *dv=NULL; float *fv=NULL; THD_3dim_dataset *dset = NULL; int debug=0; if (!debug) debug = get_odebug(); /* get the options list, maybe */ PROTECT(Opts = AS_LIST(Opts)); if ((opt = getListElement(Opts,"debug")) != R_NilValue) { debug = (int)INTEGER_VALUE(opt); if (debug>2) set_odebug(debug); if (debug > 1) INFO_message("Debug is %d\n", debug); } /* get the filename */ PROTECT(Sfname = AS_CHARACTER(Sfname)); fname = R_alloc(strlen(CHAR(STRING_ELT(Sfname,0)))+1, sizeof(char)); strcpy(fname, CHAR(STRING_ELT(Sfname,0))); if (debug >1) INFO_message("Output filename %s\n" , fname); /* get the dset structure elements */ PROTECT(Rdset = AS_LIST(Sdset)); if ((head = AS_CHARACTER(getListElement(Rdset,"head"))) == R_NilValue) { ERROR_message("No header found"); UNPROTECT(3); return(R_NilValue); } if (debug > 1) INFO_message("First head element %s\n" , CHAR(STRING_ELT(head,0))); if ((brik = AS_NUMERIC(getListElement(Rdset,"brk"))) == R_NilValue) { ERROR_message("No brick found"); UNPROTECT(3); return(R_NilValue); } dv = NUMERIC_POINTER(brik); if (debug > 1) INFO_message("First brik value %f\n" , dv[0]); ngr = NI_new_group_element(); NI_rename_group(ngr, "AFNI_dataset" ); NI_set_attribute(ngr,"AFNI_prefix", fname); if ((opt = getListElement(Opts,"idcode")) != R_NilValue) { opt = AS_CHARACTER(opt); stmp = (char *)(CHAR(STRING_ELT(opt,0))); if (stmp && !strcmp(stmp,"SET_AT_WRITE_FILENAME")) { stmp = UNIQ_hashcode(fname); NI_set_attribute(ngr, "AFNI_idcode", stmp); free(stmp); } else if (stmp && !strcmp(stmp,"SET_AT_WRITE_RANDOM")) { stmp = UNIQ_idcode() ; NI_set_attribute(ngr, "AFNI_idcode", stmp); free(stmp); } else if (stmp) { NI_set_attribute(ngr, "AFNI_idcode", (char *)(CHAR(STRING_ELT(opt,0)))); } } if ((opt = getListElement(Opts,"scale")) != R_NilValue) { scale = (int)INTEGER_VALUE(opt); if (debug > 1) INFO_message("Scale is %d\n", scale); } if ((opt = getListElement(Opts,"overwrite")) != R_NilValue) { overwrite = (int)INTEGER_VALUE(opt); if (debug > 1) INFO_message("overwrite is %d\n", overwrite); THD_force_ok_overwrite(overwrite) ; if (overwrite) THD_set_quiet_overwrite(1); } if ((opt = getListElement(Opts,"addFDR")) != R_NilValue) { addFDR = (int)INTEGER_VALUE(opt); if (debug > 1) INFO_message("addFDR is %d\n", addFDR); } PROTECT(opt = getListElement(Opts,"hist")); if ( opt != R_NilValue) { opt = AS_CHARACTER(opt); hist = R_alloc(strlen(CHAR(STRING_ELT(opt,0)))+1, sizeof(char)); strcpy(hist, CHAR(STRING_ELT(opt,0))); if (debug > 1) INFO_message("hist is %s\n", hist); } UNPROTECT(1); for (ip=0,i=0; i<length(head); ++i) { head_str = (char *)CHAR(STRING_ELT(head,i)); if (debug > 1) { INFO_message("Adding %s\n", head_str); } nel = NI_read_element_fromstring(head_str); if (!nel->vec) { ERROR_message("Empty attribute vector for\n%s\n" "This is not expected.\n", head_str); UNPROTECT(3); return(R_NilValue); } NI_add_to_group(ngr,nel); } if (debug > 1) INFO_message("Creating dset header\n"); if (!(dset = THD_niml_to_dataset(ngr, 1))) { ERROR_message("Failed to create header"); UNPROTECT(3); return(R_NilValue); } if (debug > 2) { INFO_message("Have header of %d, %d, %d, %d, scale=%d\n", DSET_NX(dset), DSET_NY(dset), DSET_NZ(dset), DSET_NVALS(dset), scale); } for (i=0; i<DSET_NVALS(dset); ++i) { if (debug > 2) { INFO_message("Putting values in sub-brick %d, type %d\n", i, DSET_BRICK_TYPE(dset,i)); } if ( ( DSET_BRICK_TYPE(dset,i) == MRI_byte || DSET_BRICK_TYPE(dset,i) == MRI_short ) ) { EDIT_substscale_brick(dset, i, MRI_double, dv+i*DSET_NVOX(dset), DSET_BRICK_TYPE(dset,i), scale ? -1.0:1.0); } else if ( DSET_BRICK_TYPE(dset,i) == MRI_double ) { EDIT_substitute_brick(dset, i, MRI_double, dv+i*DSET_NVOX(dset)); } else if ( DSET_BRICK_TYPE(dset,i) == MRI_float ) { float *ff=(float*)calloc(DSET_NVOX(dset), sizeof(float)); double *dvi=dv+i*DSET_NVOX(dset); for (ip=0; ip<DSET_NVOX(dset); ++ip) { ff[ip] = dvi[ip]; } EDIT_substitute_brick(dset, i, MRI_float, ff); } } /* THD_update_statistics( dset ) ; */ if (addFDR) { DSET_BRICK_FDRCURVE_ALLKILL(dset) ; DSET_BRICK_MDFCURVE_ALLKILL(dset) ; /* 22 Oct 2008 */ if( addFDR > 0 ){ int nFDRmask=0; /* in the future, perhaps allow for a mask */ byte *FDRmask=NULL; /* to be sent in also, for now, mask is exact */ /* 0 voxels . */ mri_fdr_setmask( (nFDRmask == DSET_NVOX(dset)) ? FDRmask : NULL ) ; ip = THD_create_all_fdrcurves(dset) ; if( ip > 0 ){ if (debug) ININFO_message("created %d FDR curve%s in dataset header", ip,(ip==1)?"\0":"s") ; } else { if (debug) ININFO_message("failed to create FDR curves in dataset header") ; } } } /* Do we have an index_list? */ if ((node_list=AS_INTEGER(getListElement(Rdset,"index_list")))!=R_NilValue) { iv = INTEGER_POINTER(node_list); if (debug > 1) INFO_message("First node index value %d, total (%d)\n", iv[0], length(node_list)); dset->dblk->nnodes = length(node_list); dset->dblk->node_list = (int *)XtMalloc(dset->dblk->nnodes * sizeof(int)); memcpy(dset->dblk->node_list, iv, dset->dblk->nnodes*sizeof(int)); } if (hist) { tross_Append_History(dset, hist); } DSET_write(dset); UNPROTECT(3); return(R_NilValue); }
#include <string.h> #include <stdio.h> #include "cardinal_config.h" #include "cardinal_value.h" #include "cardinal_debug.h" #include "cardinal_native.h" /////////////////////////////////////////////////////////////////////////////////// //// FUNCTION /////////////////////////////////////////////////////////////////////////////////// DEF_NATIVE(fn_create) ObjModule* module = AS_MODULE(args[1]); ObjList* constants = AS_LIST(args[2]); int numUpvalues = (int) AS_NUM(args[3]); int arity = (int) AS_NUM(args[4]); uint8_t* bytecode = (uint8_t*) AS_POINTER(args[5]); int size = (int) AS_NUM(args[6]); ObjString* sourcePath = AS_STRING(args[7]); ObjString* name = AS_STRING(args[8]); ObjList* lineData = AS_LIST(args[9]); ObjList* localList = AS_LIST(args[10]); ObjList* linesList = AS_LIST(args[11]); int* linesArray = new int[size]; SymbolTable locals; SymbolTable lines; cardinalSymbolTableInit(vm, &locals); cardinalSymbolTableInit(vm, &lines);