Blob of RGS/src/rgs_nodecache.c (raw blob data)

1 /*
2 * Copyright (C) 2008 Antonio, Fabio Di Narzo <antonio.fabio _at_ gmail.com>
3 *
4 * This program is free software; you can redistribute it and/or modify
5 * it under the terms of the GNU General Public License as published by
6 * the Free Software Foundation; either version 3 of the License, or (at
7 * your option) any later version.
8 *
9 * This program is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * General Public License for more details.
13 *
14 * You should have received a copy of the GNU General Public License
15 * along with this program; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
17 */
18 #include <R_ext/Rdynload.h>
19 #include "rgs_misc.h"
20 #include "rgs_node.h"
21
22 /*refresh node cache*/
23 SEXP rgs_refreshCache(SEXP model, SEXP nodeNames, SEXP nodeChildsNames) {
24 SEXP tmp; /*here only for better readability*/
25 SEXP node, nodeName, nodeChilds;
26 for(int i=0; i<length(nodeNames); i++) {
27 nodeName = VECTOR_ELT(nodeNames, i);
28 nodeChilds = VECTOR_ELT(nodeChildsNames, i);
29 node = getListElement(model, CHAR(VECTOR_ELT(nodeName, 0)));
30 RGS_NSETCACHEL(node, allocVector(VECSXP, 4)); /*alloc a new cache vector*/
31 /*set distribution pointer*/
32 tmp = R_MakeExternalPtr(R_FindSymbol(CHAR( VECTOR_ELT(RGS_NDISTRIB(node), 0) ), "", NULL), R_NilValue, R_NilValue);
33 RGS_NSETCACHE(node, 0, tmp);
34 /*set parameters pointers*/
35 RGS_NSETCACHE(node, 1, allocVector(VECSXP, length(RGS_NPARAMETERS(node))));
36 for(int i=0; i<length(RGS_NPARAMETERS(node)); i++) {
37 tmp = getListElement(model, CHAR(VECTOR_ELT(RGS_NPARAMETERS(node), i)));
38 SET_VECTOR_ELT( RGS_NCACHE(node, 1), i, R_MakeExternalPtr(tmp, R_NilValue, R_NilValue) );
39 }
40 /*set childs pointers*/
41 RGS_NSETCACHE(node, 2, allocVector(VECSXP, length(nodeChilds)));
42 for(int i=0; i<length(nodeChilds); i++) {
43 tmp = getListElement(model, CHAR(VECTOR_ELT(nodeChilds, i)));
44 SET_VECTOR_ELT( RGS_NCACHE(node, 2), i, R_MakeExternalPtr(tmp, R_NilValue, R_NilValue) );
45 }
46 /*set sampler pointer*/
47 tmp = R_MakeExternalPtr(R_FindSymbol(CHAR( VECTOR_ELT(RGS_NSAMPLER(node), 0) ), "", NULL), R_NilValue, R_NilValue);
48 RGS_NSETCACHE(node, 3, tmp);
49 }
50 return model;
51 }
52
53 SEXP rgs_testCache(SEXP model, SEXP nodeNames, SEXP childsList) {
54 /*refresh all nodes cache*/
55 for(int i=0; i<length(nodeNames); i++)
56 rgs_refreshCache(model, VECTOR_ELT(nodeNames, i), VECTOR_ELT(childsList, i));
57 /*check that all is consistent*/
58 Rprintf("a: %p\tb->a:%p\n", VECTOR_ELT(model, 0), RGS_CPARAMETERS( VECTOR_ELT(model, 1), 0 ));
59 return R_NilValue;
60 }
61
62 SEXP rgs_cdistrib(SEXP obj) {
63 SEXP ans;
64 char *a = R_alloc(2+sizeof(SEXP) * 2, sizeof(char)); /*'0x' + 2 characters per byte*/
65 sprintf(a, "%p", RGS_CDISTRIB(obj));
66 PROTECT(ans = allocVector(STRSXP, 1));
67 SET_VECTOR_ELT(ans, 0, mkChar(a));
68 UNPROTECT(1);
69 return ans;
70 }
71
72 SEXP rgs_cparameters(SEXP obj, SEXP n) {
73 return rgs_getPtr(RGS_CPARAMETERS(obj, INTEGER(n)[0]));
74 }
75
76 SEXP rgs_cchildsl(SEXP obj) {
77 return RGS_CCHILDSL(obj);
78 }
79
80 SEXP rgs_cchilds(SEXP obj, SEXP n) {
81 return rgs_getPtr(RGS_CCHILDS(obj, INTEGER(n)[0]));
82 }