Blob of RGS/src/rgs_node.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_node.h"
20 #include "rgs_distrib.h"
21
22 SEXP rgs_getValue(SEXP obj) {
23 return RGS_NVALUE(obj);
24 }
25 SEXP rgs_setValue(SEXP obj, SEXP newValue) {
26 if(length(newValue) != length(RGS_NVALUE(obj)))
27 error("new value and old value size does not match");
28 RGS_NSETVALUE(obj, REAL(newValue));
29 return newValue;
30 }
31
32 SEXP rgs_distrib(SEXP obj) {
33 return RGS_NDISTRIB(obj);
34 }
35 SEXP rgs_setdistrib(SEXP obj, SEXP newValue) {
36 RGS_NSETDISTRIB(obj, newValue);
37 return newValue;
38 }
39
40 SEXP rgs_parameters(SEXP obj) {
41 return RGS_NPARAMETERS(obj);
42 }
43 SEXP rgs_setparameters(SEXP obj, SEXP newValue) {
44 RGS_NSETPARAMETERS(obj, newValue);
45 return newValue;
46 }
47
48 SEXP rgs_extra(SEXP obj) {
49 return RGS_NEXTRA(obj);
50 }
51 SEXP rgs_setextra(SEXP obj, SEXP newValue) {
52 RGS_NSETEXTRA(obj, newValue);
53 return newValue;
54 }
55
56 SEXP rgs_sampler(SEXP obj) {
57 return RGS_NSAMPLER(obj);
58 }
59 SEXP rgs_setsampler(SEXP obj, SEXP newValue) {
60 RGS_NSETSAMPLER(obj, newValue);
61 return newValue;
62 }
63
64 SEXP rgs_cachel(SEXP obj) {
65 return RGS_NCACHEL(obj);
66 }
67 SEXP rgs_setCachel(SEXP obj, SEXP lst) {
68 RGS_NSETCACHEL(obj, lst);
69 return lst;
70 }
71
72 double rgs_compdistrib(SEXP obj) {
73 SEXP pars = RGS_CPARAMETERSL(obj);
74 SEXP par;
75 for(int i=0; i < length(pars); i++) {
76 par = RGS_CPARAMETERS(obj, i);
77 if(!RGS_CDISTRIB(par)) /*if a parameter is a logical node, update it*/
78 rgs_update(par);
79 }
80 return RGS_CDISTRIB(obj)(obj);
81 }
82
83 SEXP rgs_getdistrib(SEXP obj) {
84 SEXP ans;
85 PROTECT(ans = allocVector(REALSXP, 1));
86 REAL(ans)[0] = rgs_compdistrib(obj);
87 UNPROTECT(1);
88 return ans;
89 }
90
91 double rgs_lik(SEXP obj) {
92 double ans = 0.0;
93 int nchilds = length(RGS_CCHILDSL(obj));
94 SEXP child;
95 for(int i=0; i < nchilds; i++) {
96 child = RGS_CCHILDS(obj, i);
97 /*if distribution is null, this is a logical node: to trough childs*/
98 if(!RGS_CDISTRIB(child)) {
99 ans += rgs_lik(child);
100 } else
101 ans += rgs_compdistrib(child);
102 }
103 return ans;
104 }
105
106 SEXP rgs_getlik(SEXP obj) {
107 SEXP ans;
108 PROTECT(ans = allocVector(REALSXP, 1));
109 REAL(ans)[0] = rgs_lik(obj);
110 UNPROTECT(1);
111 return ans;
112 }
113
114 double rgs_post(SEXP obj) {
115 return RGS_CDISTRIB(obj)(obj) + rgs_lik(obj);
116 }
117
118 SEXP rgs_getpost(SEXP obj) {
119 SEXP ans;
120 PROTECT(ans = allocVector(REALSXP, 1));
121 REAL(ans)[0] = rgs_post(obj);
122 UNPROTECT(1);
123 return ans;
124 }
125
126 void rgs_Rsampler(SEXP node) {
127 SEXP samplerArgs = VECTOR_ELT( RGS_NEXTRA(node) , 1 );
128 SEXP rfun = VECTOR_ELT(samplerArgs, 0);
129 SEXP rho = VECTOR_ELT(samplerArgs, 1);
130 eval(lang1( rfun ), rho);
131 }
132
133 void rgs_update(SEXP obj) {
134 if(RGS_CSAMPLER(obj))
135 RGS_CSAMPLER(obj)(obj);
136 }
137
138 SEXP rgs_getupdate(SEXP obj) {
139 rgs_update(obj);
140 return R_NilValue;
141 }