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