deal/0000755000175100001440000000000012101525636011176 5ustar hornikusersdeal/MD50000644000175100001440000000646212101525636011516 0ustar hornikusers7d3112227e41f20f1338fd21020ff2c3 *CHANGELOG 7bfd11ae1d9bc78500c4961f51f8f3eb *DESCRIPTION e3c9a3e7728ecbdbce15668facfe6ea8 *INDEX dc016b5d0591446f2e8d659f6dbed056 *NAMESPACE ec73ca71c70ee01a1abee5a2a5a6c520 *R/addarrows.R c9c5773019c74697a26f2cfc3c5ceacb *R/autosearch.R 3235cc57dd2d867760de42aee845b795 *R/conditional.R f4bfb20495232e7daefa619fd8bfae37 *R/cycletest.R 10160883661cef28eaa9da08f45587ca *R/drawnetwork.R 508a9daf005424b39210441ad90d505c *R/findex.R d64640cd267dd14803d9653b76471271 *R/fullsimprob.R c437642302ab0d880e96e33415652be0 *R/generic.R 98f35548482a6bb38419851a04728272 *R/genlatex.R 9e328f440736fedc84f565d65b9ab50f *R/heuristic.R 9c1f4b5f62dc647c7c2ba7232a614646 *R/inspectprob.R cd61f91098d824f14c4372ebde75b247 *R/jointcont.R 450010eebd427bfe2c474d8d750b1cef *R/jointdisc.R 3069614e6be21a057d27fc57141f61c7 *R/jointprior.R 17a1348e5610968d74877348d81a5dee *R/learning.R 7db9967f24fddc96f925582edba943a1 *R/makesimprob.R d4c2cad070b9467c40b7c894ba220ff5 *R/maketrylist.R 4c25ec62d5cb82632a28181d7a06e4d4 *R/master.R 88b02e5881658d3f802493d161435060 *R/network.R 2c8e13c11f6a2ad0d90e6e25b1abc509 *R/networkfamily.R 2553d98f9f93cc10b2c274a4bcbaeae6 *R/node.R f4ed76178260c9454b73598df59995dd *R/numbermixed.R aac8cd2ca424d7288bab1d901376450e *R/perturb.R 6b709ae9bae52d3e361f9778afbb355c *R/postc.R 551be8e922d3a553f312ef4e9eb5bb61 *R/postc0.R 36f97e2b0e92b96488341a8aa5002a8b *R/postdist.R 4d64f30546067cef8d959c2a0db0d45f *R/readnet.R 86d91f993b4926ffa3f41d0e7228a9bd *R/rnetwork.R 7c210e718a89f58d5fcacc643b36be3c *R/savenet.R b3a772aef53e13345df62b504261d12f *R/unique.R 7c69cc4367c705ff377112d44faeb4fc *data/ksl.rda 0131851397897ab1f91b44948554a119 *data/ksl.txt.gz b45eb0e11f127e02ceef6545be0d2396 *data/rats.txt.gz 93e9bc264812393e4f79a5041e4be563 *data/reinis.rda 7abb4f2fd77c7445cc4e24a146bb4228 *demo/00Index 41083dbe49d0549b9340ef5fbf835a3c *demo/ksl.R a295cc012b904c54966e2cc55b01c8d0 *demo/rats.R 77bf177e0e7137ba69af7b179453ad6a *demo/regression.R b529a64f183f4aef5158c17b77d2ff4b *demo/simulation.R 171642ac0b335f7b9ae6be4efe248437 *man/autosearch.Rd c80cefa4b6ac77d27c7c5b972c638349 *man/deal-internal.Rd ea98bf740ed6477d49ff8c4f6ae9e5ba *man/drawnetwork.Rd bac7fabb72aec0f47e91140a7be8b0fa *man/genlatex.Rd 50c85b64bdbdf3381df0a170d00fe9f4 *man/insert.Rd d8aa506397c16ff55e39ffb40fa9fc66 *man/jointprior.Rd 7c6241721eb86ef24601493ea7f248a7 *man/ksl.Rd 25c4a5ee5a575a1c4fd599499174847f *man/learn.Rd 17dfa2f8f7a879580fe927bd3eb73d69 *man/makesimprob.Rd 4fb4a884a4a0ed21030ceaf68d6ba153 *man/maketrylist.Rd 3f88003e1330218509754c300f8aa1c4 *man/network.Rd 59790ae08a2e2482523a698164c1d14e *man/networkfamily.Rd 54bbd79c1186af92c7c83753cf58e668 *man/networktools.Rd 257a5a477ae7058d88e294f1450fb823 *man/node.Rd fd03de4defcd1079e728f99de4ff844f *man/numbermixed.Rd c519ab8b988b14ee1e3175711bff89b7 *man/nwfsort.Rd 62219792a7c58e6642a84a3699416fef *man/nwfunique.Rd 082ec240a0d1af4f51d96ac6293abb4d *man/perturb.Rd 81f784519eee8268681d395ccff4457a *man/prob.Rd bb95d3ad26edec38560427755e140f40 *man/rats.Rd d01afb831977ba6facaed93666fa1b42 *man/readnet.Rd 14a3ae9495d77fa8a9c7c64a2921665a *man/rnetwork.Rd 6ba00e46b4b073c781b03f877a9a2e45 *man/score.Rd 0e21cb62dab4280cfe0e917edcddca3b *src/matrix.c 7e80aef25b56e71290ce8dd9aa52ea16 *src/matrix.h aefd9f03fc3835f60b9cdc421af81b83 *src/postc.c ed6849b9711b1f4205bd9943834ba5c9 *src/postc0.c deal/src/0000755000175100001440000000000012101441103011747 5ustar hornikusersdeal/src/postc0.c0000644000175100001440000000474212101441103013332 0ustar hornikusers/* -*- Mode: C -*- * postc0.c --- Posterior for continuous node with 0 parents * Author : Claus Dethlefsen * Created On : Tue Mar 12 06:44:35 2002 * Last Modified By: Claus Dethlefsen * Last Modified On: Wed Jun 04 11:57:10 2003 * Update Count : 55 * Status : Unknown, Use with caution! */ /* ## ## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### */ #include #include void postc0(double *mu, double *tau, double *rho, double *phi, double *loglik, double *y, int *n) { int i; double logscale,logk,mscore; double oldtau,oldmu; /* Rprintf("her er mu=%f\n",*mu); Rprintf("her er tau=%f\n",*tau); Rprintf("her er rho=%f\n",*rho); Rprintf("her er phi=%f\n",*phi); Rprintf("her er loglik=%f\n",*loglik); */ for(i = 0; i < *n; i++) { logscale = log(*phi)+log1p(1.0/(*tau)); logk = lgammafn( 0.5*(1.0+*rho) ) - lgammafn(*rho*0.5); logk -= 0.5*(logscale + log(M_PI)); mscore = logk - 0.5*(*rho+1.0)*log1p( (y[i]-*mu)*(y[i]-*mu)/exp(logscale)); *loglik += mscore; oldtau = *tau; oldmu = *mu; (*tau)++; (*rho)++; /* Rprintf("her er oldmu=%f\n",oldmu); Rprintf("her er oldtau=%f\n",oldtau); Rprintf("her er mu=%f\n",*mu); Rprintf("her er tau=%f\n",*tau); */ *mu = (oldtau*(*mu)+y[i])/(*tau); *phi+= (y[i]-(*mu))*y[i] + (oldmu-(*mu))*oldtau*oldmu; /* Rprintf("logscale=%f\n",logscale); Rprintf("logk=%f\n",logk); Rprintf("mscore=%f\n",mscore); Rprintf("loglik=%f\n",*loglik); Rprintf("her er mu=%f\n",*mu); Rprintf("her er tau=%f\n",*tau); Rprintf("her er rho=%f\n",*rho); Rprintf("her er phi=%f\n",*phi); Rprintf("her er loglik=%f\n",*loglik); */ } } deal/src/postc.c0000644000175100001440000001304612101441103013247 0ustar hornikusers/* -*- Mode: C -*- * postc.c --- Posterior for continuous node with continuous parents * Author : Claus Dethlefsen * Created On : Tue Mar 12 06:44:35 2002 * Last Modified By: Claus Dethlefsen * Last Modified On: Wed Jun 04 11:56:51 2003 * Update Count : 227 * Status : Unknown, Use with caution! */ /* ## ## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### */ #include #include #include "matrix.h" void postc(double *mu, double *tau, double *rho, double *phi, double *loglik, double *y, double *z, int *n, int *d) { /* mu: dx1 matrix tau: dxd matrix rho: real phi: real loglik: real y: nx1 matrix z: nxd matrix n: int d: int */ int i,j; double logscale,logk,mscore; double **oldtau=0, **oldmu=0, **mtau, **mmu, **tauinv=0; double **zero, **zi, **ziy; /* allocate space for matrices */ mtau = dmatrix(1,*d,1,*d); zi = dmatrix(1,*d,1,1); ziy = dmatrix(1,*d,1,1); mmu = dmatrix(1,*d,1,1); zero = dmatrix(1,*d,1,1); /* copy arguments into the matrices */ asmatrix(mu,mmu,*d,1); asmatrix(tau,mtau,*d,*d); /* show input */ /* Rprintf("Mu=(%d x 1)\n",*d); printmat(mmu,*d,1); Rprintf("Tau=\n"); printmat(mtau,*d,*d); Rprintf("Rho=%f\n",*rho); Rprintf("Phi=%f\n",*phi); Rprintf("loglik=%f\n",*loglik); Rprintf("Entering loop\n"); Rprintf("z=(%d x %d)\n",*n,*d); printmat(mz,*n,*d); */ for(i = 1; i <= *n; i++) { /* Rprintf("y[i]=%f\n",y[i]); Rprintf("\n"); printmat(mtau,*d,*d); Rprintf("\n"); */ tauinv = matcopy(mtau,*d,*d); invers(tauinv, *d, zero, 1); /* printmat(tauinv,*d,*d); Rprintf("\n"); */ for (j=1; j<=*d; j++) { zi[j][1] = z[j-1+(i-1)*(*d)]; } logscale = log(*phi) + log1p( matmult( transp(zi,*d,1), matmult(tauinv,zi,*d,*d,1), 1,*d,1 )[1][1] ); logk = lgammafn( 0.5*(1.0+*rho) ) - lgammafn(*rho*0.5); logk -= 0.5*(logscale + log(M_PI)); mscore = logk - 0.5*(*rho+1)* log1p( (y[i-1] - matmult( transp(zi,*d,1), mmu,1,*d,1 )[1][1] ) * (y[i-1] - matmult( transp(zi,*d,1), mmu,1,*d,1 )[1][1]) /exp(logscale) ); *loglik += mscore; /* Rprintf("logscale=%f\n",logscale); Rprintf("logk=%f\n",logk); Rprintf("mscore=%f\n",mscore); Rprintf("her er loglik=%f\n",*loglik); */ oldtau = matcopy(mtau,*d,*d); oldmu = matcopy(mmu,*d,1); /* Rprintf("mtau=\n"); printmat(mtau,*d,*d); Rprintf("zi=\n"); printmat(zi,*d,1); Rprintf("transp(zi,*d,1)=\n"); printmat(transp(zi,*d,1),1,*d); Rprintf("matmult(zi,transp(zi,*d,1),*d,1,*d)\n"); printmat(matmult(zi,transp(zi,*d,1),*d,1,*d),*d,*d); Rprintf("matsum(mtau, matmult(zi,transp(zi,*d,1),*d,1,*d) , *d, *d )\n"); printmat(matsum(mtau, matmult(zi,transp(zi,*d,1),*d,1,*d) , *d, *d ),*d,*d); */ mtau = matsum(mtau, matmult(zi,transp(zi,*d,1),*d,1,*d) , *d, *d ); /* Rprintf("Tau=\n"); printmat(mtau,*d,*d); */ tauinv = matcopy(mtau,*d,*d); invers(tauinv, *d, zero, 1); for (j=1;j<=*d;j++) ziy[j][1] = zi[j][1]*y[i-1]; mmu = matmult(tauinv, matsum( matmult(oldtau,mmu,*d,*d,1), ziy, *d,1) ,*d,*d,1); /* Rprintf("Mu=\n"); printmat(mmu,*d,1); */ (*rho)++; /* Rprintf("t(zi)=\n"); printmat(transp(zi,*d,1),1,*d); Rprintf("mmu=\n"); printmat(mmu,*d,1); Rprintf("t(zi)*mmu=\n"); printmat(matmult(transp(zi,*d,1),mmu,1,*d,1),1,1); */ (*phi) += (y[i-1]- matmult( transp(zi,*d,1), mmu,1,*d,1)[1][1])*y[i-1] + matmult( transp( matminus(oldmu,mmu,*d,1), *d,1 ), matmult( oldtau, oldmu, *d,*d,1 ), 1,*d,1 )[1][1]; /* Rprintf("Phi=%f\n",*phi); */ } /* RESULTS */ /* Rprintf("Mu=\n"); printmat(mmu,*d,1); Rprintf("Tau=\n"); printmat(mtau,*d,*d); Rprintf("Rho=%f\n",*rho); Rprintf("Phi=%f\n",*phi); Rprintf("loglik=%f\n",*loglik); */ for (i=1; i<=*d;i++) mu[i-1] = mmu[i][1]; for (i=1; i<=*d; i++) for (j=1; j<=*d; j++) tau[(*d)*(j-1)+i-1] = mtau[i][j]; /* Rprintf("Returned mu=\n"); for (i=0; i<*d; i++) Rprintf("%f\n",mu[i]); Rprintf("Returned tau=\n"); for (i=0; i<(*d)*(*d); i++) Rprintf("%f\n",tau[i]); */ /* destruct the matrices double **oldtau, **oldmu, **mtau, **mz, **mmu, **tauinv; double **zero, **zi, **ziy; */ /* free_dmatrix(mtau,1,*d,1,*d); free_dmatrix(mz,1,*n,1,*d); free_dmatrix(zi,1,*d,1,1); free_dmatrix(ziy,1,*d,1,1); free_dmatrix(mmu,1,*d,1,1); free_dmatrix(zero,1,*d,1,1); free_dmatrix(oldtau,1,*d,1,*d); free_dmatrix(tauinv,1,*d,1,*d); free_dmatrix(oldmu,1,*d,1,1); */ } deal/src/matrix.h0000644000175100001440000000346412101441103013433 0ustar hornikusers/* -*- Mode: C -*- * matrix.h --- * Author : Claus Dethlefsen * Created On : Thu Mar 14 06:47:52 2002 * Last Modified By: Claus Dethlefsen * Last Modified On: Tue May 07 09:39:46 2002 * Update Count : 22 * Status : Unknown, Use with caution! */ /* ## ## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### */ extern double ** dmatrix( int, int, int, int ); extern int * ivector( int, int ); extern void free_ivector( int *, int, int ); extern int invers(double **a, int n, double **b, int m); extern void printmat( double **, int, int); extern void asmatrix( double *, double **, int, int); extern double** matcopy(double **, int, int); extern double** matmult(double **,double **, int, int, int); extern double** matsum(double **a, double **b, int nr, int nc); extern double** matminus(double **a, double **b, int nr, int nc); extern double** transp (double **a, int n, int m); deal/src/matrix.c0000644000175100001440000001272312101441103013424 0ustar hornikusers/* -*- Mode: C -*- * matrix.c --- Simple matrix functions for use with postc.c * Author : Claus Dethlefsen * Created On : Thu Mar 14 06:48:02 2002 * Last Modified By: Claus Dethlefsen * Last Modified On: Wed Jun 04 11:56:23 2003 * Update Count : 36 * Status : Ready */ /* ## ## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### */ #include "matrix.h" #include #include int *ivector(int nl, int nh) { int *v; v=(int *) R_alloc((unsigned) (nh-nl+1)*sizeof(int),sizeof(int)); if ( v == NULL ){ error("memory allocation failure in ivector()"); return(NULL); } return v-nl; } void free_ivector(int *v, int nl, int nh) { free((char*) (v+nl)); } double **dmatrix(int nrl, int nrh, int ncl, int nch) { int i; double **m; m=(double **) R_alloc((unsigned) (nrh-nrl+1)*sizeof(double*),sizeof(double*)); if ( m == NULL ){ error("memory allocation failure 1 in dmatrix()"); return(NULL); } m -= nrl; for(i=nrl;i<=nrh;i++) { m[i]=(double *) R_alloc((unsigned) (nch-ncl+1)*sizeof(double),sizeof(double)); if ( m[i] == NULL ){ error("memory allocation failure 2 in dmatrix()"); return(NULL); } m[i] -= ncl; } return m; } void printmat(double **mat, int nr, int nc) { int i,j; for (i=1; i<=nr; i++) { for (j=1; j<=nc; j++) Rprintf("%f\t",mat[i][j]); Rprintf("\n"); } } void asmatrix(double *vek, double **mat, int nr, int nc) { int i,j; for (i=1; i<=nr; i++) { for (j=1; j<=nc; j++) { mat[i][j] = vek[j-1+(i-1)*nc]; } } } double** matcopy(double **mat, int nr, int nc) { /* copy mat[i][j] into nat[i][j] */ int i,j; double **nat; nat = dmatrix(1,nr,1,nc); /* Rprintf("(nr=%d,nc=%d)\n",nr,nc); Rprintf("(mat=%d)\n",mat); Rprintf("(mat[1][1]=%f)\n",mat[1][1]); */ for (i=1; i<=nr; i++) { for (j=1; j<=nc; j++) { nat[i][j] = mat[i][j]; } } return(nat); } double** matmult(double **a, double **b, int nra, int nca, int ncb) { double **c; int i,j,k; c = dmatrix(1,nra,1,ncb); for (i=1; i<=nra; i++) for (j=1; j<=ncb; j++) c[i][j] = 0.0; for (i=1; i<=nra; i++) for (k=1; k<=ncb; k++) for (j=1; j<=nca; j++) c[i][k] += a[i][j]*b[j][k]; return(c); } double** matsum(double **a, double **b, int nr, int nc) { double **c; int i,j; c = dmatrix(1,nr,1,nc); for (i=1; i<=nr; i++) for (j=1; j<=nc; j++) c[i][j] = a[i][j] + b[i][j]; return(c); } double** matminus(double **a, double **b, int nr, int nc) { double **c; int i,j; c = dmatrix(1,nr,1,nc); for (i=1; i<=nr; i++) for (j=1; j<=nc; j++) c[i][j] = a[i][j] - b[i][j]; return(c); } double** transp (double **a, int n, int m) { double **b; int i,j; b = dmatrix(1,m,1,n); for (i=1; i<=n; i++) for (j=1; j<=m; j++) b[j][i] = a[i][j]; return(b); } int invers(double **a, int n, double **b, int m) { int *indxc,*indxr,*ipiv; int i,icol=1,irow=1,j,k,l,ll; double big,dum,pivinv; if( (indxc = ivector(1,n)) == NULL){ return(-1); } if( (indxr = ivector(1,n)) == NULL){ return(-1); } if( (ipiv = ivector(1,n)) == NULL){ return(-1); } for (j=1;j<=n;j++) ipiv[j]=0; for (i=1;i<=n;i++) { big=0.0; for (j=1;j<=n;j++) if (ipiv[j] != 1) for (k=1;k<=n;k++) { if (ipiv[k] == 0) { if (fabs(a[j][k]) >= big) { big=fabs(a[j][k]); irow=j; icol=k; } } else if (ipiv[k] > 1){ error("Invers: Singular Matrix-1"); return(-1); } } ++(ipiv[icol]); if (irow != icol) { for (l=1;l<=n;l++){ double temp=a[irow][l]; a[irow][l]=a[icol][l]; a[icol][l]=temp; } for (l=1;l<=m;l++){ double temp=b[irow][l]; b[irow][l]=b[icol][l]; b[icol][l]=temp; } } indxr[i]=irow; indxc[i]=icol; if (a[icol][icol] == 0.0){ error("Invers: Singular Matrix-2"); return(-1); } pivinv=1.0/a[icol][icol]; a[icol][icol]=1.0; for (l=1;l<=n;l++) a[icol][l] *= pivinv; for (l=1;l<=m;l++) b[icol][l] *= pivinv; for (ll=1;ll<=n;ll++) if (ll != icol) { dum=a[ll][icol]; a[ll][icol]=0.0; for (l=1;l<=n;l++) a[ll][l] -= a[icol][l]*dum; for (l=1;l<=m;l++) b[ll][l] -= b[icol][l]*dum; } } for (l=n;l>=1;l--) { if (indxr[l] != indxc[l]){ for (k=1;k<=n;k++){ double temp = a[k][indxr[l]]; a[k][indxr[l]] = a[k][indxc[l]]; a[k][indxc[l]] = temp; } } } return(0); } deal/man/0000755000175100001440000000000012101441103011733 5ustar hornikusersdeal/man/score.Rd0000644000175100001440000000252112101441102013334 0ustar hornikusers% -*- Mode: Rd -*- % score.Rd --- % Author : Claus Dethlefsen % Created On : Sat May 25 23:03:31 2002 % Last Modified By: Claus Dethlefsen % Last Modified On: Thu Dec 04 13:08:17 2008 % Update Count : 10 % Status : Unknown, Use with caution! % \name{score} \alias{score} \alias{score.network} \alias{score.node} %- Also NEED an `\alias' for EACH other topic documented here. \title{Network score} \encoding{latin1} \description{Accessor for the score from a node or network } \usage{ score(x,...) \method{score}{node} (x,...) \method{score}{network} (x,...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{an object of class \code{node} or \code{network}.} \item{\dots}{additional arguments for specific methods.} } \value{For networks, the log network score is returned. For nodes, the contribution to the log network score is returned. } \references{ Further information about \bold{deal} can be found at:\cr \url{http://www.math.aau.dk/~dethlef/novo/deal}. } \author{ Susanne Gammelgaard Bottcher \email{alma@math.aau.dk}, \cr Claus Dethlefsen \email{cld@rn.dk}. } %\note{ ~~further notes~~ } % ~Make other sections like WARNING with \section{WARNING }{....} ~ \keyword{models} deal/man/rnetwork.Rd0000644000175100001440000000424512101441102014101 0ustar hornikusers% -*- Mode: Rd -*- % simulation.Rd --- % Author : Claus Dethlefsen % Created On : Sat May 25 23:04:28 2002 % Last Modified By: Claus Dethlefsen % Last Modified On: Thu Dec 04 13:17:59 2008 % Update Count : 26 % Status : Unknown, Use with caution! % \encoding{latin1} \name{rnetwork} \alias{rnetwork} %- Also NEED an `\alias' for EACH other topic documented here. \title{Simulation of data sets with a given dependency structure} \description{ Given a network with nodes having the \code{simprob} property, \code{rnetwork} simulates a data set. } \usage{ rnetwork(nw, n=24, file="") } %- maybe also `usage' for other objects documented here. \arguments{ \item{nw}{an object of class \code{\link{network}}, where each node has the property \code{simprob} (see \code{\link{makesimprob}}).} \item{n}{an integer, which gives the number of cases to simulate.} \item{file}{a string. If non-empty, the data set is stored there.} } \details{ The variables are simulated one at a time in an order that ensures that the parents of the node have already been simulated. For discrete variables a multinomial distribution is used and for continuous variables, a Gaussian distribution is used, according to the \code{simprob} property in each node. } \value{ A data frame with one row per case. If a file name is given, a file is created with the data set. } \references{ Further information about \bold{deal} can be found at:\cr \url{http://www.math.aau.dk/~dethlef/novo/deal}. } \author{ Susanne Gammelgaard Bottcher \email{alma@math.aau.dk}, \cr Claus Dethlefsen \email{cld@rn.dk}. } %\note{ ~~further notes~~ } % ~Make other sections like WARNING with \section{WARNING }{....} ~ \examples{ A <- factor(NA,levels=paste("A",1:2,sep="")) B <- factor(NA,levels=paste("B",1:3,sep="")) c1 <- NA c2 <- NA df <- data.frame(A,B,c1,c2) nw <- network(df,doprob=FALSE) # doprob must be FALSE nw <- makesimprob(nw) # create simprob properties set.seed(944) sim <- rnetwork(nw,n=100) # create simulated data frame } \keyword{models} deal/man/readnet.Rd0000644000175100001440000000345412101441102013651 0ustar hornikusers\encoding{latin1} \name{readnet} \alias{readnet} \alias{savenet} %- Also NEED an `\alias' for EACH other topic documented here. \title{Reads/saves .net file} \description{ Reads/saves a Bayesian network specification in the \code{.net} language (see \url{http://developer.hugin.com/documentation/net/}). } \usage{ readnet(con=file("default.net")) savenet(nw, con=file("default.net")) } %- maybe also `usage' for other objects documented here. \arguments{ \item{con}{a connection.} \item{nw}{an object of class \code{\link{network}}.} } \details{ \code{readnet} reads only the structure of a network, i.e.\ the directed acyclic graph. \code{savenet} exports the \code{prob} property for each node in the network object along with the network structure defined by the parents of each node. } \value{ \code{readnet} creates an object of class \code{\link{network}} with the nodes specified as in the \code{.net} connection. The network has not been learned and the nodes do not have \code{prob} properties (see \code{\link{prob.network}}). \code{savenet} writes the object to the connection. } \author{ Susanne Gammelgaard Bottcher \email{alma@math.aau.dk}, \cr Claus Dethlefsen \email{cld@rn.dk}. } \references{ Further information about \bold{deal} can be found at:\cr \url{http://www.math.aau.dk/~dethlef/novo/deal}. } \note{The call to \code{readnet(savenet(network))} is \emph{not} the identity function as information is thrown away in both \code{savenet} and \code{readnet}.} \seealso{\code{\link{network}}} \examples{ data(rats) nw <- network(rats) \dontrun{savenet(nw,file("default.net"))} \dontrun{nw2 <- readnet(file("default.net"))} \dontrun{nw2 <- prob(nw2,rats)} } \keyword{ iplot }% at least one, from doc/KEYWORDS deal/man/rats.Rd0000644000175100001440000000233412101441102013174 0ustar hornikusers% -*- Mode: Rd -*- % rats.Rd --- % Author : Claus Dethlefsen % Created On : Sat May 25 23:04:20 2002 % Last Modified By: Claus Dethlefsen % Last Modified On: Wed Mar 16 13:54:36 2005 % Update Count : 12 % Status : Unknown, Use with caution! % \name{rats} \alias{rats} \non_function{} \title{Weightloss of rats} \description{ An artificial data set. 24 rats (12 female, 12 male) have been randomized to use one of three drugs (products for loosing weight). The weightloss for each rat is noted after one and two weeks. } \format{A data frame with 4 variables. \describe{ \item{Sex}{a factor with two levels: "M" (male), "F" (female)} \item{Drug}{a factor with three levels: "D1", "D2", "D3" (three types)} \item{W1}{a numeric: weightloss, week one.} \item{W2}{a numeric: weightloss, week 2.} } } \references{ Morrison, D.F. (1976). Multivariate Statistical Methods. McGraw-Hill, USA. Edwards, D. (1995). Introduction to Graphical Modelling, Springer-Verlag. New York. Further information about \bold{deal} can be found at:\cr \url{http://www.math.aau.dk/~dethlef/novo/deal}. } \keyword{datasets} deal/man/prob.Rd0000644000175100001440000000630512101441102013167 0ustar hornikusers% -*- Mode: Rd -*- % prob.Rd --- % Author : Claus Dethlefsen % Created On : Sat May 25 23:03:31 2002 % Last Modified By: Claus Dethlefsen % Last Modified On: Tue Nov 01 14:19:23 2011 % Update Count : 21 % Status : Unknown, Use with caution! % \encoding{latin1} \name{prob} \alias{prob} \alias{prob.network} \alias{prob.node} \alias{localprob} \alias{localprob<-} \alias{localprior} \alias{localposterior} %- Also NEED an `\alias' for EACH other topic documented here. \title{Local probability distributions} \description{Methods for accessing or changing the local probability distributions and for accessing the local prior and posterior distributions } \usage{ prob(x,df,...) \method{prob}{node} (x,df,nw,...) \method{prob}{network} (x,df,...) localprob(nw) localprob(nw,name) <- value localprior(node) localposterior(node) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{an object of class \code{node} or \code{network}.} \item{df}{a data frame, where the columns define the variables. A continuous variable should have type \code{numeric} and discrete varibles should have type \code{\link[base]{factor}}.} \item{nw}{an object of class \code{\link{network}}.} \item{node}{an object of class \code{\link{node}}.} \item{name}{a string, which gives the node name.} \item{\dots}{additional arguments for specific methods.} \item{value}{If the node is continuous, this is a numeric vector with the conditional variance and the conditional regression coefficients arising from a regression on the continuous parents, using data. If the node has discrete parents, it is a matrix with a row for each configuration of the discrete parents. If the node is discrete, it is a multiway array which gives the conditional probability distribution for each configuration of the discrete parents.} } \details{ The \code{prob} methods add local probability distributions to each node. If the node is continuous, this is a numeric vector with the conditional variance and the conditional regression coefficients arising from a regression on the continuous parents, using data. If the node has discrete parents, \code{prob} is a matrix with a row for each configuration of the discrete parents. If the node is discrete, \code{prob} is a multiway array which gives the conditional probability distribution for each configuration of the discrete parents. The generated \code{prob} can be replaced to match the prior information available. \code{localprob} returns the probability distribution for each node in the network. In a learned network, the local prior and posterior can be accessed for each node using \code{localprior} and \code{localposterior}. } \references{ Further information about \bold{deal} can be found at:\cr \url{http://www.math.aau.dk/~dethlef/novo/deal}. } \author{ Susanne Gammelgaard Bottcher \email{alma@math.aau.dk}, \cr Claus Dethlefsen \email{cld@rn.dk}. } %\note{ ~~further notes~~ } % ~Make other sections like WARNING with \section{WARNING }{....} ~ \keyword{models} deal/man/perturb.Rd0000644000175100001440000000535112101441102013710 0ustar hornikusers% -*- Mode: Rd -*- % perturb.Rd --- % Author : Claus Dethlefsen % Created On : Sat May 25 23:03:54 2002 % Last Modified By: Claus Dethlefsen % Last Modified On: Thu Dec 04 13:17:30 2008 % Update Count : 31 % Status : Unknown, Use with caution! % \encoding{latin1} \name{perturb} \alias{perturb} %- Also NEED an `\alias' for EACH other topic documented here. \title{Perturbs a network} \description{Randomly insert/delete/turn arrows to obtain another network. } \usage{ perturb(nw,data,prior,degree=size(nw),trylist=vector("list",size(nw)), nocalc=FALSE,timetrace=TRUE) } %- maybe also `usage' for other objects documented here. \arguments{ \item{nw}{an object of class \code{network}, from which arrows are added/removed/turned.} \item{data}{a data frame used for learning the network, see \code{\link{network}}.} \item{prior}{a list containing parameter priors, generated by \code{\link{jointprior}}.} \item{degree}{an integer, which gives the number of attempts to randomly insert/remove/turn an arrow.} \item{trylist}{a list used internally for reusing learning of nodes, see \code{\link{maketrylist}}.} \item{nocalc}{a logical. If \code{TRUE} no learning procedure is called, see eg. \code{\link{rnetwork}}.} \item{timetrace}{a logical. If \code{TRUE}, prints some timing information on the screen.} } \details{ Given the initial network, a new network is constructed by randomly choosing an action: remove, turn, add. After the action is chosen, we choose randomly among all possibilities of that action. If there are no possibilites, the unchanged network is returned.} \value{A list with two elements that may be accessed using \code{\link{getnetwork}} and \code{\link{gettrylist}}. The elements are \item{nw}{an object of class \code{\link{network}} with the generated network.} \item{trylist}{an updated list used internally for reusing learning of nodes, see \code{\link{maketrylist}}.} } \references{ Further information about \bold{deal} can be found at:\cr \url{http://www.math.aau.dk/~dethlef/novo/deal}. } \author{ Susanne Gammelgaard Bottcher \email{alma@math.aau.dk}, \cr Claus Dethlefsen \email{cld@rn.dk}. } %\note{ ~~further notes~~ } % ~Make other sections like WARNING with \section{WARNING }{....} ~ \examples{ set.seed(200) data(rats) fit <- network(rats) fit.prior <- jointprior(fit) fit <- getnetwork(learn(fit,rats,fit.prior)) fit.new <- getnetwork(perturb(fit,rats,fit.prior,degree=10)) data(ksl) ksl.nw <- network(ksl) ksl.rand <- getnetwork(perturb(ksl.nw,nocalc=TRUE,degree=10)) plot(ksl.rand) } \keyword{iplot} deal/man/nwfunique.Rd0000644000175100001440000000346412101441102014251 0ustar hornikusers% -*- Mode: Rd -*- % nwfunique.Rd --- % Author : Claus Dethlefsen % Created On : Sat May 25 23:03:51 2002 % Last Modified By: Claus Dethlefsen % Last Modified On: Thu Dec 04 13:17:22 2008 % Update Count : 20 % Status : Unknown, Use with caution! % \name{unique.networkfamily} \alias{unique.networkfamily} \encoding{latin1} %- Also NEED an `\alias' for EACH other topic documented here. \title{Makes a network family unique.} \description{Removes networks that are equal or equivalent to networks already in the network family. } \usage{ \method{unique}{networkfamily}(x,incomparables=FALSE,equi=FALSE,timetrace=FALSE,epsilon=1e-12,...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{an object of class \code{networkfamily}.} \item{incomparables}{a logical, but has no effect.} \item{equi}{a logical. If \code{TRUE}, also equivalent networks are thrown out (\emph{i.e.} if their score is within \code{epsilon} from another network).} \item{timetrace}{a logical. If \code{TRUE}, prints some timing information on the screen.} \item{epsilon}{a numeric, which measures how close network scores are allowed to be from each other to be 'equivalent'.} \item{...}{further arguments (no effect)} } \author{ Susanne Gammelgaard Bottcher \email{alma@math.aau.dk}, \cr Claus Dethlefsen \email{cld@rn.dk}. } \references{ Further information about \bold{deal} can be found at:\cr \url{http://www.math.aau.dk/~dethlef/novo/deal}. } %\note{ ~~further notes~~ } % ~Make other sections like WARNING with \section{WARNING }{....} ~ \examples{ data(rats) rats.nwf <- networkfamily(rats) rats.nwf2<- unique(getnetwork(rats.nwf),equi=TRUE) } \keyword{iplot} deal/man/nwfsort.Rd0000644000175100001440000000237412101441102013731 0ustar hornikusers% -*- Mode: Rd -*- % nwfsort.Rd --- % Author : Claus Dethlefsen % Created On : Sat May 25 23:03:47 2002 % Last Modified By: Claus Dethlefsen % Last Modified On: Thu Dec 04 13:17:12 2008 % Update Count : 12 % Status : Unknown, Use with caution! % \encoding{latin1} \name{nwfsort} \alias{nwfsort} %- Also NEED an `\alias' for EACH other topic documented here. \title{Sorts a list of networks} \description{According to the \code{score} property of the networks in a network family, the networks are sorted and the relative score, i.e.\ the score of a network relative to the highest score, is attached to each network as the \code{relscore} property. } \usage{ nwfsort(nwf) } %- maybe also `usage' for other objects documented here. \arguments{ \item{nwf}{an object of class \code{networkfamily}.} } \author{ Susanne Gammelgaard Bottcher \email{alma@math.aau.dk}, \cr Claus Dethlefsen \email{cld@rn.dk}. } %\note{ ~~further notes~~ } % ~Make other sections like WARNING with \section{WARNING }{....} ~ \references{ Further information about \bold{deal} can be found at:\cr \url{http://www.math.aau.dk/~dethlef/novo/deal}. } \keyword{iplot} deal/man/numbermixed.Rd0000644000175100001440000000360612101441102014545 0ustar hornikusers% -*- Mode: Rd -*- % numbermixed.Rd --- % Author : Claus Dethlefsen % Created On : Sat May 25 23:03:38 2002 % Last Modified By: Claus Dethlefsen % Last Modified On: Mon Jan 05 14:37:29 2009 % Update Count : 15 % Status : Unknown, Use with caution! % \encoding{latin1} \name{numbermixed} \alias{numbermixed} %- Also NEED an `\alias' for EACH other topic documented here. \title{The number of possible networks} \description{Calculates the number of different directed acyclic graphs for a set of discrete and continuous nodes. } \usage{ numbermixed(nd,nc) } %- maybe also `usage' for other objects documented here. \arguments{ \item{nd}{an integer, which gives the number of discrete nodes.} \item{nc}{an integer, which gives the number of continuous nodes.} } \details{ No arrows are allowed from continuous nodes to discrete nodes. Cycles are not allowed. The number of networks is given by Bottcher (2003), using the result in Robinson (1977). When nd+nc>15, the procedure is quite slow. } \value{ A numeric containing the number of directed acyclic graphs with the given node configuration. } \references{ Bottcher, S.G. (2003). Learning Conditional Gaussian Networks. \url{http://www.math.aau.dk/~alma}. Aalborg University, 2003. Robinson, R.W. (1977). Counting unlabeled acyclic digraphs, Lecture Notes in Mathematics, 622: Combinatorial Mathematics. Further information about \bold{deal} can be found at:\cr \url{http://www.math.aau.dk/~dethlef/novo/deal}. } \author{ Susanne Gammelgaard Bottcher \email{alma@math.aau.dk}, \cr Claus Dethlefsen \email{cld@rn.dk}. } %\note{ ~~further notes~~ } % ~Make other sections like WARNING with \section{WARNING }{....} ~ \examples{ numbermixed(2,2) \dontrun{numbermixed(5,10)} } \keyword{models} deal/man/node.Rd0000644000175100001440000001407012101441102013150 0ustar hornikusers% -*- Mode: Rd -*- % node.Rd --- % Author : Claus Dethlefsen % Created On : Sat May 25 23:03:31 2002 % Last Modified By: Claus Dethlefsen % Last Modified On: Tue Nov 01 13:58:35 2011 % Update Count : 85 % Status : Unknown, Use with caution! % \encoding{latin1} \name{node} \alias{node} \alias{plot.node} \alias{print.node} \alias{nodes} \alias{nodes<-} %- Also NEED an `\alias' for EACH other topic documented here. \title{Representation of nodes} \description{An important part of a \code{\link{network}} is the list of nodes. The nodes summarize the local properties of a node, given the parents of the node. } \usage{ node (idx,parents,type="discrete",name=paste(idx), levels=2,levelnames=paste(1:levels),position=c(0,0)) \method{print}{node} (x,filename=NA,condposterior=TRUE,condprior=TRUE,...) \method{plot}{node} (x,cexscale=10,notext=FALSE,...) nodes(nw) nodes(nw) <- value } %- maybe also `usage' for other objects documented here. \arguments{ \item{x}{an object of class \code{node}.} \item{parents}{a numeric vector with indices of the parents of the node.} \item{idx}{an integer, which gives the index of the node (the column number of the corresponding data frame).} \item{type}{a string, which gives the type of the node. Either \code{"discrete"} (for factors) or \code{"continuous"} (for numeric).} \item{name}{a string, which gives the name used when plotting and printing. Defaults to the column name in the data frame.} \item{levels}{an integer. If \code{type} is \code{"discrete"}, this is the number of levels for the discrete variable.} \item{levelnames}{if \code{type} is \code{"discrete"}, this is a vector of strings (same length as \code{levels}) with the names of the levels. If \code{type} is \code{"continuous"}, the argument is ignored.} \item{position}{a numeric vector with coordinates where the node should appear in the plot. Usually set by \code{\link{network}} and \code{\link{drawnetwork}}.} \item{nw}{an object of class \code{\link{network}}.} \item{value}{a list of elements of class \code{\link{node}}.} \item{filename}{a string or \code{NA}. If not \code{NA}, output is printed to a file.} \item{condprior}{a logical. If \code{TRUE}, the conditional prior is printed, see \code{\link{conditional}}.} \item{condposterior}{a logical. If \code{TRUE}, the conditional posterior is printed, see \code{\link{learn}}.} \item{cexscale}{a numeric. Scale parameter to set the size of the nodes.} \item{notext}{a logical. If \code{TRUE}, no text is displayed in the nodes on the plot.} \item{\dots}{additional plot arguments.} } \details{ The operations on a node are typically done when operating on a \code{\link{network}}, so these functions are not to be called directly. When a network is created with \code{network}, the nodes in the nodelist are created using the \code{node} procedure. Local probability distributions are added as the property \code{prob} to each node using \code{prob.node}. If the node is continuous, this is a numeric vector with the conditional variance and the conditional regression coefficients arising from a regression on the continuous parents, using data. If the node has discrete parents, \code{prob} is a matrix with a row for each configuration of the discrete parents. If the node is discrete, \code{prob} is a multiway array which gives the conditional probability distribution for each configuration of the discrete parents. The generated \code{prob} can be replaced to match the prior information available. \code{nodes} gives the list of nodes of a network. \code{localprob} gives the probability distribution for each node in the network. } \value{ The \code{node} creator function returns an object of class \code{node}, which is a list with the following elements (properties), \item{idx}{an integer. A unique index for this node. It MUST correspond to the column index of the variable in the data frame.} \item{name}{a string. The printed name of the node.} \item{type}{a string. Either \code{"continuous"} or \code{"discrete"}.} \item{levels}{an integer. If the node is of type \code{"discrete"}, this integer is the number of levels of the node.} \item{levelnames}{if \code{type} is \code{"discrete"}, this is a vector of strings (same length as \code{levels}) with the names of the levels. If \code{type} is \code{"continuous"}, the node does not have this property.} \item{parents}{a vector of indices of the parents to this node. It is best to manage this vector using the \code{\link{insert}} function.} \item{prob}{a numeric vector, matrix or multiway array, giving the initial probability distribution. If the node is discrete, \code{prob} is a multiway array. If the node is continuous, \code{prob} is a matrix with one row for each configuration of the discrete parents, reducing to a vector if the node has no discrete parents.} \item{condprior}{a list, generated by \code{\link{conditional}} giving the parameter priors deduced from \code{\link{jointprior}} using the master prior procedure (see \code{\link{localmaster}}). } \item{condposterior}{a list, which gives the parameter posteriors obtained from \code{\link{learnnode}}.} \item{loglik}{a numeric giving the log likelihood contribution for this node, calculated in \code{\link{learnnode}}.} \item{simprob}{a numeric vector, matrix or multiway array similar to \code{prob}, added by \code{\link{makesimprob}} and used by \code{\link{rnetwork}}.} } \references{ Further information about \bold{deal} can be found at:\cr \url{http://www.math.aau.dk/~dethlef/novo/deal}. } \author{ Susanne Gammelgaard Bottcher \email{alma@math.aau.dk}, \cr Claus Dethlefsen \email{cld@rn.dk}. } %\note{ ~~further notes~~ } % ~Make other sections like WARNING with \section{WARNING }{....} ~ \keyword{models} deal/man/networktools.Rd0000644000175100001440000000404612101441102014777 0ustar hornikusers% -*- Mode: Rd -*- % networktools.Rd --- % Author : Claus Dethlefsen % Created On : Wed Jan 07 12:35:45 2004 % Last Modified By: Claus Dethlefsen % Last Modified On: Fri Jan 09 12:36:08 2004 % Update Count : 13 % Status : Unknown, Use with caution! % \name{Network tools} \alias{modelstring} \alias{makenw} \alias{size} \alias{as.network} \alias{banlist} \alias{getnetwork} \alias{gettrylist} \alias{banlist<-} \title{Tools for manipulating networks} \description{Various extraction/replacement functions for networks} \usage{ modelstring(x) makenw(tb,template) as.network(nwstring,template) size(x) banlist(x) banlist(x) <- value getnetwork(x) gettrylist(x) } \arguments{ \item{x}{an object of class \code{\link{network}}.} \item{tb}{a table output from \code{\link{autosearch}} or \code{\link{heuristic}} in the list property \code{table}. Can be translated into a \code{\link{networkfamily}}.} \item{template}{an object of class \code{\link{network}} with the same nodes as the networks described in the table \code{tb}.} \item{nwstring}{a string representing the network.} \item{value}{a numeric matrix with two columns. Each row contains the indices \code{i -> j} of arrows that may not be allowed in the directed acyclic graph.} } \details{ The string representation of a network is a minimal size representation to speed up calculations. The functions \code{modelstring}, \code{as.network} and \code{makenw} converts between the string represention and network objects. \code{size} extracts the number of nodes in a network object. \code{banlist} extracts the banlist from a network object. \code{getnetwork} and \code{gettrylist} are accessor function that extracts a network object or trylist from the result from \code{\link{autosearch}}, \code{\link{heuristic}}, \code{\link{learn}}, \code{\link{perturb}}, \code{\link{networkfamily}}, \code{\link{drawnetwork}}. } \keyword{models} deal/man/networkfamily.Rd0000644000175100001440000000761612101441102015126 0ustar hornikusers% -*- Mode: Rd -*- % networkfamily.Rd --- % Author : Claus Dethlefsen % Created On : Sat May 25 23:03:26 2002 % Last Modified By: Claus Dethlefsen % Last Modified On: Thu Dec 04 13:16:42 2008 % Update Count : 47 % Status : Unknown, Use with caution! % \encoding{latin1} \name{networkfamily} \alias{networkfamily} \alias{print.networkfamily} \alias{plot.networkfamily} %- Also NEED an `\alias' for EACH other topic documented here. \title{Generates and learns all networks for a set of variables.} \description{Method for generating and learning all networks that are possible for a given set of variables. These may be plotted or printed. Also, functions for sorting according to the network score (see \code{\link{nwfsort}}) and for making a network family unique (see the \code{unique} method for \code{networkfamily} objects) are available. } \usage{ networkfamily(data,nw=network(data), prior=jointprior(nw), trylist=vector("list",size(nw)), timetrace=TRUE) \method{print}{networkfamily}(x,...) \method{plot}{networkfamily}(x,layout=, cexscale=5,arrowlength=0.1,sscale=7,...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{nw}{an object of class \code{\link{network}}. This should be the empty network for the set of variables.} \item{data}{a data frame used for learning the network, see \code{\link{network}}.} \item{prior}{a list containing parameter priors, generated by \code{\link{jointprior}}.} \item{trylist}{a list used internally for reusing learning of nodes, see \code{\link{maketrylist}}.} \item{timetrace}{a logical. If \code{TRUE}, prints some timing information on the screen.} \item{x}{an object of class \code{networkfamily}.} \item{layout}{a numeric two dimensional vector with the number of plots in the rows and columns of each plotting page. Default set to \code{rep(min(1+floor(sqrt(length(x))),5),2)}.} \item{cexscale}{a numeric. A scaling parameter to set the size of the nodes.} \item{arrowlength}{a numeric, which gives the length of the arrow heads.} \item{sscale}{a numeric. The nodes are initially placed on a circle with radius \code{sscale}.} \item{...}{additional plot arguments passed to the plot method for network objects.} } \details{ \code{networkfamily} generates and learns all possible networks with the nodes given as in the initial network \code{nw}. This is done by successively trying to generate the networks with all possible arrows to/from each node (see \code{\link{addarrows}}). If there is a ban list present in \code{nw} (see \code{\link{network}}), then this is respected, as are the restrictions described in \code{\link{insert}}. After generation of all possible networks, a test for cycles (see \code{\link{cycletest}}) is performed and only networks with directed acyclic graphs are returned. } \value{The function \code{networkfamily} returns a list with two components, \item{nw}{an object of class \code{networkfamily}.} \item{trylist}{an updated list used internally for reusing learning of nodes, see \code{\link{maketrylist}}.} } \note{ Generating all possible networks can be \emph{very} time consuming! } \author{ Susanne Gammelgaard Bottcher \email{alma@math.aau.dk}, \cr Claus Dethlefsen \email{cld@rn.dk}. } \references{ Further information about \bold{deal} can be found at:\cr \url{http://www.math.aau.dk/~dethlef/novo/deal}. } \seealso{\code{\link{network}}, \code{\link{genlatex}}, \code{\link{heuristic}}, \code{\link{nwfsort}}, \code{\link{unique.networkfamily}}, \code{\link{elementin}}, \code{\link{addarrows}}, \code{\link{cycletest}} } \examples{ data(rats) allrats <- getnetwork(networkfamily(rats)) plot(allrats) print(allrats) } \keyword{iplot} deal/man/network.Rd0000644000175100001440000001246112101441102013716 0ustar hornikusers% -*- Mode: Rd -*- % network.Rd --- % Author : Claus Dethlefsen % Created On : Sat May 25 23:03:21 2002 % Last Modified By: Claus Dethlefsen % Last Modified On: Thu Dec 04 13:16:33 2008 % Update Count : 89 % Status : Unknown, Use with caution! % \name{network} \alias{network} \alias{plot.network} \alias{print.network} %- Also NEED an `\alias' for EACH other topic documented here. \title{Bayesian network data structure} \description{ A Bayesian network is represented as an object of class \code{network}. Methods for printing and plotting are defined. } \encoding{latin1} \usage{ network(df,specifygraph=FALSE,inspectprob=FALSE, doprob=TRUE,yr=c(0,350),xr=yr) \method{print}{network}(x,filename=NA,condposterior=FALSE, condprior=FALSE,...) \method{plot}{network} (x,arrowlength=.25, notext=FALSE, sscale=7,showban=TRUE,yr=c(0,350),xr=yr, unitscale=20,cexscale=8,...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{df}{a data frame, where the columns define the variables. A continuous variable should have type \code{numeric} and discrete varibles should have type \code{\link[base]{factor}}.} \item{specifygraph}{a logical. If \code{TRUE}, provides a call to \code{\link{drawnetwork}} to interactively specify a directed acyclic graph and possibly a ban list (see below).} \item{inspectprob}{a logical. If \code{TRUE}, provides a plot of the graph and possibility to inspect the calculated probability distribution by clicking on the nodes.} \item{doprob}{a logical. If \code{TRUE}, do not calculate a probability distribution. Used for example in \code{\link{rnetwork}}. } \item{x}{an object of class \code{\link{network}}.} \item{filename}{a string or \code{NA}. If not \code{NA}, output is printed to a file.} \item{condprior}{a logical. If \code{TRUE}, the conditional prior is printed, see \code{\link{conditional}}.} \item{condposterior}{a logical. If \code{TRUE}, the conditional posterior is printed, see \code{\link{learn}}.} \item{sscale}{a numeric. The nodes are initially placed on a circle with radius \code{sscale}.} \item{unitscale}{a numeric. Scale parameter for chopping off arrow heads.} \item{cexscale}{a numeric. Scale parameter to set the size of the nodes.} \item{arrowlength}{a numeric containing the length of the arrow heads.} \item{xr}{a numeric vector with two components containing the range on x-axis.} \item{yr}{a numeric vector with two components containing the range on y-axis.} \item{notext}{a logical. If \code{TRUE}, no text is displayed in the nodes on the plot.} \item{showban}{a logical. If \code{TRUE}, banned arrows are shown in red.} \item{\dots}{additional plot arguments, passed to \code{\link{plot.node}}.} } \value{ The \code{netork} creator function returns an object of class \code{network}, which is a list with the following elements (properties), \item{nodes}{a list of objects of class \code{node}. If \code{doprob} is \code{TRUE}, the nodes are given the property \code{prob} which is the initial probability distribution used by \code{\link{jointprior}}.} \item{n}{an integer containing the number of nodes in the network.} \item{discrete}{a numeric vector of indices of discrete nodes.} \item{continuous}{a numeric vector of indices of continuous nodes.} \item{banlist}{a numeric matrix with two columns. Each row contains the indices \code{i -> j} of arrows that may not be allowed in the directed acyclic graph.} \item{score}{a numeric added by \code{\link{learn}} and is the log network score.} \item{relscore}{a numeric added by \code{\link{nwfsort}} and is the relative network score -- compared with the best network in a network family.} } \seealso{\code{\link{networkfamily}}, \code{\link{node}}, \code{\link{rnetwork}}, \code{\link{learn}}, \code{\link{drawnetwork}}, \code{\link{jointprior}}, \code{\link{heuristic}}, \code{\link{nwequal}} } \references{ Further information about \bold{deal} can be found at:\cr \url{http://www.math.aau.dk/~dethlef/novo/deal}. } \author{ Susanne Gammelgaard Bottcher \email{alma@math.aau.dk}, \cr Claus Dethlefsen \email{cld@rn.dk}. } %\note{ ~~further notes~~ } % ~Make other sections like WARNING with \section{WARNING }{....} ~ \examples{ A <- factor(rep(c("A1","A2"),50)) B <- factor(rep(rep(c("B1","B2"),25),2)) thisnet <- network( data.frame(A,B) ) set.seed(109) sex <- gl(2,4,label=c("male","female")) age <- gl(2,2,8) yield <- rnorm(length(sex)) weight <- rnorm(length(sex)) mydata <- data.frame(sex,age,yield,weight) mynw <- network(mydata) # adjust prior probability distribution localprob(mynw,"sex") <- c(0.4,0.6) localprob(mynw,"age") <- c(0.6,0.4) localprob(mynw,"yield") <- c(2,0) localprob(mynw,"weight")<- c(1,0) print(mynw) plot(mynw) prior <- jointprior(mynw) mynw <- getnetwork(learn(mynw,mydata,prior)) thebest <- getnetwork(autosearch(mynw,mydata,prior)) print(mynw,condposterior=TRUE) \dontrun{savenet(mynw,file("yield.net"))} } \keyword{models} deal/man/maketrylist.Rd0000644000175100001440000000535412101441102014600 0ustar hornikusers% -*- Mode: Rd -*- % maketrylist.Rd --- % Author : Claus Dethlefsen % Created On : Sat May 25 23:02:52 2002 % Last Modified By: Claus Dethlefsen % Last Modified On: Thu Dec 04 13:16:24 2008 % Update Count : 25 % Status : Unknown, Use with caution! % \name{maketrylist} \alias{maketrylist} \encoding{latin1} %- Also NEED an `\alias' for EACH other topic documented here. \title{Creates the full trylist} \description{For faster learning, a trylist is maintained as a lookup table for a given parent configuration of a node.} \usage{ maketrylist(initnw,data,prior=jointprior(network(data)),timetrace=FALSE) } %- maybe also `usage' for other objects documented here. \arguments{ \item{initnw}{an object of class \code{\link{network}}, from which the search is started. } \item{data}{a data frame used for learning the network, see \code{\link{network}}.} \item{prior}{a list containing parameter priors, generated by \code{\link{jointprior}}.} \item{timetrace}{a logical. If \code{TRUE}, prints some timing information on the screen.} } \details{This procedure is included for illustrative purposes. For each node in the network, all possible parent configurations are created and learned. The result is called a trylist. To create the full trylist is very time-consuming, and a better choice is to maintain a trylist while searching and indeed this is automatically done. The trylist is given as output to all functions that call the learning procedure and can be given as an argument. } \value{A list with one element per node in the network. In the list, element \emph{i} is a matrix with two columns: a string with the indices of the parent nodes, separated by ":", and a numeric with the log-likelihood contribution of the node given the parent configuration. Whenever learning is performed of a node given a parent configuration, the trylist is consulted to yield faster learning, especially useful when using \code{\link{autosearch}} or \code{\link{heuristic}}. } \references{ Further information about \bold{Deal} can be found at:\cr \url{http://www.math.aau.dk/~dethlef/novo/deal}. } \author{ Susanne Gammelgaard Bottcher \email{alma@math.aau.dk}, \cr Claus Dethlefsen \email{cld@rn.dk}. } \seealso{ \code{\link{networkfamily}}, \code{\link{autosearch}} \code{\link{heuristic}} } \examples{ data(rats) rats.nw <- network(rats) rats.pr <- jointprior(rats.nw,12) rats.nw <- getnetwork(learn(rats.nw,rats,rats.pr)) rats.tr <- maketrylist(rats.nw,rats,rats.pr) rats.hi <- getnetwork(heuristic(rats.nw,rats,rats.pr,trylist=rats.tr)) } \keyword{models} deal/man/makesimprob.Rd0000644000175100001440000000574512101441102014545 0ustar hornikusers% -*- Mode: Rd -*- % makesimprob.Rd --- % Author : Claus Dethlefsen % Created On : Sat May 25 23:02:48 2002 % Last Modified By: Claus Dethlefsen % Last Modified On: Thu Dec 04 13:16:10 2008 % Update Count : 25 % Status : Unknown, Use with caution! % \name{makesimprob} \alias{makesimprob} \encoding{latin1} %- Also NEED an `\alias' for EACH other topic documented here. \title{Make a suggestion for simulation probabilities} \description{Creates local probability distributions reflecting the graph of the network. These are attached as a \code{simprob} property to each node in the network and can be edited and used for \code{\link{rnetwork}}. } \usage{ makesimprob(nw, s2=function(idx,cf) { cf <- as.vector(cf) xs <- (1:length(cf)) log(xs\%*\%cf+1) }, m0=function(idx,cf) { cf <- as.vector(cf) xs <- (1:length(cf))^2 .69*(xs\%*\%cf) }, m1=function(idx,cf) { cf <- as.vector(cf) xs <- (1:length(cf))*10 idx*(cf\%*\%xs) }) } %- maybe also `usage' for other objects documented here. \arguments{ \item{nw}{an object of class \code{\link{network}}.} \item{s2}{function that returns the variance as a function of the node index and the configuration of the discrete variables.} \item{m0}{function that returns the intercept as a function of the node index and the configuration of the discrete variables.} \item{m1}{function that returns the regression coefficients as a function of the node index and the configuration of the discrete variables.} } \details{ For each node, the local \code{simprob} is determined. If the node is discrete, the probability distribution is uniform (and thus not reflecting the dependence in the graph, as it should). If the node is continuous, one mean and variance is attached per configuration of the discrete parents. The mean depends on the continuos parents and is the regression coefficients determined by the functions \code{m0} (intercept) and \code{m1} (regression coefficients). The variance is determined by the function \code{s2}. } \value{The network object \code{nw}, where each node has attached the property \code{simprob}.} \references{ Further information about \bold{deal} can be found at:\cr \url{http://www.math.aau.dk/~dethlef/novo/deal}. } \seealso{\code{\link{rnetwork}}} \author{ Susanne Gammelgaard Bottcher \email{alma@math.aau.dk}, \cr Claus Dethlefsen \email{cld@rn.dk}. } %\note{ ~~further notes~~ } % ~Make other sections like WARNING with \section{WARNING }{....} ~ \keyword{models} deal/man/learn.Rd0000644000175100001440000001106112101441102013321 0ustar hornikusers% -*- Mode: Rd -*- % learn.Rd --- % Author : Claus Dethlefsen % Created On : Sat May 25 23:02:26 2002 % Last Modified By: Claus Dethlefsen % Last Modified On: Mon Jan 05 14:37:16 2009 % Update Count : 88 % Status : Unknown, Use with caution! % \name{learn} \alias{learn} \encoding{latin1} %- Also NEED an `\alias' for EACH other topic documented here. \title{Estimation of parameters in the local probability distributions} \description{Updates the distributions of the parameters in the network, based on a prior network and data. Also, the network score is calculated. } \usage{ learn (nw, df, prior=jointprior(nw), nodelist=1:size(nw), trylist=vector("list",size(nw)), timetrace=FALSE) } %- maybe also `usage' for other objects documented here. \arguments{ \item{nw}{an object of class \code{\link{network}}.} \item{df}{a data frame used for learning the network, see \code{\link{network}}.} \item{prior}{a list containing parameter priors, generated by \code{\link{jointprior}}.} \item{nodelist}{a numeric vector of indices of nodes to be learned.} \item{trylist}{a list used internally for reusing learning of nodes, see \code{\link{maketrylist}}.} \item{timetrace}{a logical. If \code{TRUE}, prints some timing information on the screen.} } \details{ The procedure \code{learn} determines the master prior, local parameter priors and local parameter posteriors, see Bottcher (2001). It may be called on all nodes (default) or just a single node. From the joint prior distribution, the marginal distribution of all parameters in the family consisting of the node and its parents can be determined. This is the master prior, see \code{\link{localmaster}}. The local parameter priors are now determined by conditioning in the master prior distribution, see \code{\link{conditional}}. The hyperparameters associated with the local parameter prior distribution is attached to each node in the property \code{condprior}. Finally, the local parameter posterior distributions are calculated (see \code{\link{post}}) and attached to each node in the property \code{condposterior}. A so-called trylist is maintained to speedup the learning process. The trylist consists of a list of matrices for each node. The matrix for a given node holds previously evaluated parent configurations and the corresponding log-likelihood contribution. If a node with a certain parent configuration needs to be learned, it is checked, whether the node has already been learned. The previously learned nodes are given as input in the trylist parameter and is updated in the learning procedure. When one or more nodes in a network have been learned, the network score is updated and attached to the network in the property \code{score}. The learning procedure is called from various functions using the principle, that networks should always be updated with their score. Thus, e.g.\ \code{\link{drawnetwork}} keeps the network updated when the graph is altered. } \seealso{\code{\link{networkfamily}}, \code{\link{jointprior}}, \code{\link{maketrylist}}, \code{\link{network}} } \value{A list with two elements that may be accessed using \code{\link{getnetwork}} and \code{\link{gettrylist}}. The elements are \item{nw}{an object of class \code{\link{network}}, with the \code{condposterior} properties updated for the nodes. Also, the property \code{score} is updated and contains the network score. The contribution to the network score for each node is contained in the property \code{loglik} for each node.} \item{trylist}{an updated list used internally for reusing learning of nodes, see \code{\link{maketrylist}}.} } \references{ Bottcher, S.G. (2001). Learning Bayesian Networks with Mixed Variables, Artificial Intelligence and Statistics 2001, Morgan Kaufmann, San Francisco, CA, USA, 149-156. Further information about \bold{deal} can be found at:\cr \url{http://www.math.aau.dk/~dethlef/novo/deal}. } \author{ Susanne Gammelgaard Bottcher \email{alma@math.aau.dk}, \cr Claus Dethlefsen \email{cld@rn.dk}. } \examples{ data(rats) fit <- network(rats) fit.prior <- jointprior(fit,12) fit.learn <- learn(fit,rats,fit.prior,timetrace=TRUE) fit.nw <- getnetwork(fit.learn) fit.learn2<- learn(fit,rats,fit.prior,trylist=gettrylist(fit.learn),timetrace=TRUE) } \keyword{iplot} deal/man/ksl.Rd0000644000175100001440000000202012101441102013004 0ustar hornikusers \name{ksl} \alias{ksl} \non_function{} \title{Health and social characteristics} \description{ Data from a study measuring health and social characteristics of representative samples of Danish 70 year olds, taken in 1967 and 1984. } \format{A data frame with variables of both discrete and continuous types. \describe{ \item{FEV}{Forced ejection volume} \item{Kol}{Cholesterol} \item{Hyp}{Hypertension (no/yes)} \item{logBMI}{Logarithm of Body Mass Index} \item{Smok}{Smoking (no/yes)} \item{Alc}{Alcohol consumption (seldom/frequently)} \item{Work}{Working (yes/no)} \item{Sex}{male/female} \item{Year}{Survey year (1967/1984)} } } \references{ % Morrison, D.F. (1976). Multivariate Statistical Methods. McGraw-Hill, USA. % Edwards, D. (1995). Introduction to Graphical Modelling, % Springer-Verlag. New York. Further information about \bold{deal} can be found at:\cr \url{http://www.math.aau.dk/~dethlef/novo/deal}. } \keyword{datasets} deal/man/jointprior.Rd0000644000175100001440000001172012101441102014421 0ustar hornikusers% -*- Mode: Rd -*- % jointprior.Rd --- % Author : Claus Dethlefsen % Created On : Sat May 25 23:02:21 2002 % Last Modified By: Claus Dethlefsen % Last Modified On: Mon Jan 05 14:36:51 2009 % Update Count : 65 % Status : Unknown, Use with caution! % \name{jointprior} \alias{jointprior} \encoding{latin1} %- Also NEED an `\alias' for EACH other topic documented here. \title{Calculates the joint prior distribution} \description{Given a network with a \code{prob} property for each node, derives the joint probability distribution. Then the quantities needed in the local master procedure for finding the local parameter priors are deduced.} \usage{ jointprior(nw,N=NA,phiprior="bottcher",timetrace=FALSE) } %- maybe also `usage' for other objects documented here. \arguments{ \item{nw}{an object of class \code{\link{network}}. Each node must have a \code{prob} property to describe the local probability distribution. The \code{prob} property is created using \code{\link{prob}} method for network objects, which is called by the \code{\link{network}} function.} \item{N}{an integer, which gives the size of the imaginary data base. If this is too small, \code{NA}'s may be created in the output, resulting in errors in \code{\link{learn}}. If no \code{N} is given, the procedure tries to set a value as low as possible.} \item{phiprior}{a string, which specifies how the prior for phi is calculated. Either \code{phiprior="bottcher"} or \code{phiprior="heckerman"} can be used.} \item{timetrace}{a logical. If \code{TRUE}, prints some timing information on the screen.} } \details{For the discrete part of the network, the joint probability distribution is calculated by multiplying together the local probability distributions. Then, \code{jointalpha} is determined by multiplying each entry in the joint probability distribution by the size of the imaginary data base \code{N}. For the mixed part of the network, for each configuration of the discrete variables, the joint Gaussian distribution of the continuous variables is constructed and represented by \code{jointmu} (one row for each configuration of the discrete parents) and \code{jointsigma} (a list of matrices -- one for each configuration of the discrete parents). The configurations of the discrete parents are ordered according to \code{\link{findex}}. The algorithm for constructing the joint distribution of the continuous variables is described in Shachter and Kenley (1989). Then, \code{jointalpha}, \code{jointnu}, \code{jointrho}, \code{mu} and \code{jointphi} are deduced. These quantities are later used for deriving local parameter priors. For each configuration \code{i} of the discrete variables, \deqn{\nu_i=\rho_i=\alpha_i}{nu[i]=rho[i]=jointalpha[i]} and \deqn{\phi_i = (\nu_i -1)\Sigma_i}{phi[i] = (nu[i] -1)Sigma[i]} if \code{phiprior="bottcher"}, see Bottcher(2001) and \deqn{\phi_i = \nu_i(\rho_i -2)\Sigma_i/(\nu_i+1)}{phi[i] = nu[i](rho[i] -2)Sigma[i]/(nu[i]+1) } if \code{phiprior="heckerman"}, see Heckerman, Geiger and Chickering (1995). } \value{ A list with the following elements, \item{jointalpha}{a table used in the local master procedure for discrete variables.} \item{jointnu}{a table used in the local master procedure for continuous variables.} \item{jointrho}{a table used in the local master procedure for continuous variables.} \item{jointmu}{a numeric matrix used in the local master procedure for continuous variables.} \item{jointsigma}{a list of numeric matrices (not used in further calculations).} \item{jointphi}{a list of numeric matrices used in the local master procedure for continuous variables.} } \seealso{\code{\link{network}}, \code{\link{prob}} } \references{ Bottcher, S.G. (2001). Learning Bayesian Networks with Mixed Variables, Artificial Intelligence and Statistics 2001, Morgan Kaufmann, San Francisco, CA, USA, 149-156. Heckerman, D., Geiger, D. and Chickering, D. (1995). Learning Bayesian networks: The combination of knowledge and statistical data. Machine Learning, 20: 197-243. Shachter, R.D. and Kenley, C.R. (1989), Gaussian influence diagrams. Management Science, 35:527-550. Further information about \bold{deal} can be found at:\cr \url{http://www.math.aau.dk/~dethlef/novo/deal}. } \author{ Susanne Gammelgaard Bottcher \email{alma@math.aau.dk}, \cr Claus Dethlefsen \email{cld@rn.dk}. } %\note{ ~~further notes~~ } % ~Make other sections like WARNING with \section{WARNING }{....} ~ \examples{ data(rats) rats.nw <- network(rats) rats.prior <- jointprior(rats.nw,12) \dontrun{savenet(rats.nw,file("rats.net"))} \dontrun{rats.nw <- readnet(file("rats.net"))} \dontrun{rats.nw <- prob(rats.nw,rats)} \dontrun{rats.prior <- jointprior(rats.nw,12)} } \keyword{models} deal/man/insert.Rd0000644000175100001440000000560712101441101013534 0ustar hornikusers% -*- Mode: Rd -*- % insert.Rd --- % Author : Claus Dethlefsen % Created On : Sat May 25 23:02:17 2002 % Last Modified By: Claus Dethlefsen % Last Modified On: Mon Jan 05 14:35:15 2009 % Update Count : 28 % Status : Unknown, Use with caution! % \name{insert} \alias{insert} \alias{remover} \encoding{latin1} %- Also NEED an `\alias' for EACH other topic documented here. \title{Insert/remove an arrow in network} \description{Inserts/removes one arrow in a network (if legal) } \usage{ insert (nw,j,i,df,prior,nocalc=FALSE,trylist=vector("list",size(nw))) remover(nw,j,i,df,prior,nocalc=FALSE,trylist=vector("list",size(nw))) } %- maybe also `usage' for other objects documented here. \arguments{ \item{nw}{an object of class \code{\link{network}}.} \item{j}{integer, giving the index of the 'from' node.} \item{i}{integer, giving the index of the 'to' node.} \item{df}{a data frame used for learning the network, see \code{\link{network}}.} \item{prior}{a list describing parameter priors, generated by \code{\link{jointprior}}.} \item{nocalc}{a logical. If \code{TRUE}, learning is not called.} \item{trylist}{a list, used internally for reusing learning of nodes, see \code{\link{maketrylist}}.} } \details{ Examines if the arrow from \code{j} to \code{i} is legal according to the following criteria Arrows from/to the same node are not legal. Arrows from continous nodes to discrete nodes are not legal. Arrows banned in ban list are not legal, see \code{\link{drawnetwork}}. Arrows already existing in the network are not legal. If the arrow is not legal, a \code{NULL} network is returned. Otherwise, the arrow is inserted/removed, the network is re-learned (if \code{nocalc} is \code{FALSE}). The trylist is updated. } \value{A list with two elements \item{nw}{an object of class \code{\link{network}} with the arrow added/removed if this is possible. If not, \code{NULL} is returned.} \item{trylist}{an updated list, used internally for reusing learning of nodes, see \code{\link{maketrylist}}.} } \references{ Further information about \bold{deal} can be found at:\cr \url{http://www.math.aau.dk/~dethlef/novo/deal}. } \author{ Susanne Gammelgaard Bottcher \email{alma@math.aau.dk}, \cr Claus Dethlefsen \email{cld@rn.dk}. } %\note{ ~~further notes~~ } % ~Make other sections like WARNING with \section{WARNING }{....} ~ \examples{ data(rats) rats.nw <- network(rats) rats.nw <- getnetwork(insert(rats.nw,2,1,nocalc=TRUE)) rats.prior <- jointprior(rats.nw,12) rats.nw2 <- network(rats) rats.nw2 <- getnetwork(learn(rats.nw2,rats,rats.prior)) rats.nw2 <- getnetwork(insert(rats.nw2,1,2,rats,rats.prior)) rats.nw3 <- getnetwork(remover(rats.nw2,1,2,rats,rats.prior)) } \keyword{iplot} deal/man/genlatex.Rd0000644000175100001440000000645512101441101014041 0ustar hornikusers% -*- Mode: Rd -*- % genlatex.Rd --- % Author : Claus Dethlefsen % Created On : Sat May 25 23:02:07 2002 % Last Modified By: Claus Dethlefsen % Last Modified On: Thu Dec 04 13:39:54 2008 % Update Count : 20 % Status : Unknown, Use with caution! % \name{genlatex} \alias{genlatex} \alias{genpicfile} \encoding{latin1} %- Also NEED an `\alias' for EACH other topic documented here. \title{From a network family, generate LaTeX output} \description{The networks in a network family is arranged as pictex-graphs in a LaTeX-table. } \usage{ genlatex(nwl,outdir="pic/",prefix="scoretable",picdir="",picpre="pic", ncol=5,nrow=7,width=12/ncol,vadjust=-1.8) genpicfile (nwl,outdir="pic/",prefix="pic",w=1.6,h=1.6,bigscale=3) } %- maybe also `usage' for other objects documented here. \arguments{ \item{nwl}{object of class \code{networkfamily} containing a list of objects of class \code{network}.} \item{outdir}{character string, the directory for storing output.} \item{prefix}{character string, the filename (without extension) of the LaTeX file. The filenames of the picfiles begin with the given prefix.} \item{picdir}{character string, the directory where pic-files are stored.} \item{picpre}{character string, prefix for pic-files.} \item{ncol}{integer, the number of columns in LaTeX table.} \item{nrow}{integer, the number of rows in LaTeX table.} \item{width}{numeric, the width of each cell in the LaTeX table.} \item{vadjust}{numeric, the vertical adjustment in LaTeX table.} \item{w}{numeric, the width of pictex objects} \item{h}{numeric, the height of pictex objects} \item{bigscale}{numeric, the scaling of the best network, which is output in 'nice.tex'} } \value{Files: \item{\{outdir\}\{picpre\}xx.tex}{one pictex file for each network in the network family, indexed by xx.} \item{\{outdir\}\{prefix\}.tex}{LaTeX file with table including all pictex files.} \item{\{outdir\}\{picpre\}nice.tex}{pictex file with the best network.} } \seealso{\code{\link{networkfamily}}, \code{\link{pictex}}} \author{ Susanne Gammelgaard Bottcher \email{alma@math.aau.dk}, \cr Claus Dethlefsen \email{cld@rn.dk}. } %\note{ ~~further notes~~ } % ~Make other sections like WARNING with \section{WARNING }{....} ~ \examples{ data(rats) allrats <- getnetwork(networkfamily(rats,network(rats))) allrats <- nwfsort(allrats) \dontrun{dir.create("c:/temp")} \dontrun{genpicfile(allrats,outdir="c:/temp/pic/")} \dontrun{genlatex(allrats,outdir="c:/temp/pic/",picdir="c:/temp/pic/")} ## LATEX FILE: #\documentclass{article} #\usepackage{array,pictex} #\begin{document} #\input{scoretable} #\input{picnice} #\end{document} #data(ksl) #ksl.nw <- network(ksl) #ksl.prior <- jointprior(ksl.nw,64) #mybanlist <- matrix(c(5,5,6,6,7,7,9, # 8,9,8,9,8,9,8),ncol=2) #banlist(ksl.nw) <- mybanlist #ksl.nw <- getnetwork(learn(ksl.nw,ksl,ksl.prior)) #ksl.search <- autosearch(ksl.nw,ksl,ksl.prior, # trace=TRUE) #ksl.searchlist <- makenw(ksl.search$table,ksl.search$nw) #ksl.searchlist <- nwfsort(ksl.searchlist) \dontrun{genpicfile(ksl.searchlist)} \dontrun{genlatex(ksl.searchlist)} } \keyword{iplot} deal/man/drawnetwork.Rd0000644000175100001440000000703112101441101014570 0ustar hornikusers% -*- Mode: Rd -*- % drawnetwork.Rd --- % Author : Claus Dethlefsen % Created On : Sat May 25 23:01:44 2002 % Last Modified By: Claus Dethlefsen % Last Modified On: Thu Dec 04 13:15:16 2008 % Update Count : 50 % Status : Unknown, Use with caution! % \name{drawnetwork} \alias{drawnetwork} %- Also NEED an `\alias' for EACH other topic documented here. \title{Graphical interface for editing networks} \description{\code{drawnetwork} allows the user to specify a Bayesian network through a point and click interface. } \encoding{latin1} \usage{ drawnetwork(nw,df,prior,trylist=vector("list",size(nw)), unitscale=20,cexscale=8, arrowlength=.25,nocalc=FALSE, yr=c(0,350),xr=yr,...) } %- maybe also `usage' for other objects documented here. \arguments{ \item{nw}{an object of class \code{\link{network}} to be edited.} \item{df}{a data frame used for learning the network, see \code{\link{network}}.} \item{prior}{a list containing parameter priors, generated by \code{\link{jointprior}}.} \item{trylist}{a list used internally for reusing learning of nodes, see \code{\link{maketrylist}}.} \item{cexscale}{a numeric passed to the plot method for network objects. Measures the scaled size of text and symbols.} \item{arrowlength}{a numeric passed to the plot method for network objects. Measures the length of the edges of the arrowheads.} \item{nocalc}{a logical. If \code{TRUE}, no learning procedure is called, see eg. \code{\link{rnetwork}}.} \item{unitscale}{a numeric passed to the plot method for network objects. Scale parameter for chopping off arrow heads.} \item{xr}{a numeric vector with two components containing the range on x-axis.} \item{yr}{a numeric vector with two components containing the range on y-axis.} \item{...}{additional plot arguments, passed to the plot method for network objects.} } \details{ To insert an arrow from node 'A' to node 'B', first click node 'A' and then click node 'B'. When the graph is finished, click 'stop'. To specify that an arrow must not be present, press 'ban' (a toggle) and draw the arrow. This is shown as a red dashed arrow. It is possible to ban both directions between nodes. The ban list is stored with the network in the property \code{banlist}. It is a matrix with two columns. Each row is the 'from' node index and the 'to' node index, where the indices are the column number in the data frame. Note that the network score changes as the network is re-learned whenever a change is made (unless \code{nocalc} is \code{TRUE}). } \value{A list with two elements that may be accessed using \code{\link{getnetwork}} and \code{\link{gettrylist}}. The elements are \item{nw}{an object of class \code{\link{network}} with the final network.} \item{trylist}{an updated list used internally for reusing learning of nodes, see \code{\link{maketrylist}}.} } \seealso{\code{\link{network}} } \references{ Further information about \bold{deal} can be found at:\cr \url{http://www.math.aau.dk/~dethlef/novo/deal}. } \author{ Susanne Gammelgaard Bottcher \email{alma@math.aau.dk}, \cr Claus Dethlefsen \email{cld@rn.dk}. } \examples{ data(rats) rats.nw <- network(rats) rats.prior <- jointprior(rats.nw,12) rats.nw <- getnetwork(learn(rats.nw,rats,rats.prior)) \dontrun{newrat <- getnetwork(drawnetwork(rats.nw,rats,rats.prior))} } \keyword{models} deal/man/deal-internal.Rd0000644000175100001440000000637212101441101014747 0ustar hornikusers% -*- Mode: Rd -*- % deal-internal.Rd --- % Author : Claus Dethlefsen % Created On : Wed Jan 07 10:32:46 2004 % Last Modified By: Claus Dethlefsen % Last Modified On: Thu Dec 04 13:08:48 2008 % Update Count : 40 % Status : Unknown, Use with caution! % \name{deal-internal} \alias{printline} \alias{post} \alias{reinis} \alias{post0} \alias{postc} \alias{postc0c} \alias{postcc} \alias{learnnode} \alias{udisclik} \alias{addrandomarrow} \alias{turnrandomarrow} \alias{deleterandomarrow} \alias{addarrows} \alias{addarrow} \alias{turnarrow} \alias{removearrow} \alias{cycletest} \alias{findleaf} \alias{conditional.cont} \alias{conditional.disc} \alias{conditional} \alias{cond.node} \alias{cond} \alias{elementin} \alias{findex} \alias{jointdisc} \alias{jointcont} \alias{localmaster} \alias{postdist} \alias{postdist.node} \alias{nwequal} \alias{inspectprob} \alias{DealTestClass-class} \alias{networkclass-class} \alias{integerOrNULL-class} \alias{graphComponents-methods} \alias{graphComponents,networkclass-method} \alias{setGraphComponents-methods} \alias{setGraphComponents,networkclass-method} \alias{Str-methods} \alias{Str,networkclass-method} \alias{label,DealTestClass-method} \alias{width,DealTestClass-method} \alias{dynamic.Graph-methods} \alias{dynamic.Graph,networkclass-method} \alias{testEdge-methods} \alias{modifyModel-methods} \alias{modifyModel,networkclass-method} \alias{testEdge,networkclass-method} \title{deal internal functions} \description{ These are functions internally called by other functions in the package \code{deal} and not meant to be called by the user. } \usage{ printline(s="-",n=60) post (mu,tau,rho,phi,y,z,timetrace=FALSE) postc (mu,tau,rho,phi,y,z,timetrace=FALSE) postcc (mu,tau,rho,phi,y,z,timetrace=FALSE) post0 (mu,tau,rho,phi,y,timetrace=FALSE) postc0c(mu,tau,rho,phi,y,timetrace=FALSE) learnnode(node,nw,df,prior=jointprior(nw),timetrace=FALSE) udisclik(node,nw,df) addrandomarrow(nw,data,prior,trylist=vector("list",size(nw)),nocalc=FALSE, timetrace=FALSE) turnrandomarrow(nw,data,prior,trylist=vector("list",size(nw)),nocalc=FALSE, timetrace=FALSE) deleterandomarrow(nw,data,prior,trylist=vector("list",size(nw)),nocalc=FALSE, timetrace=timetrace) addarrows(nw, node, data, prior,trylist=vector("list",size(nw))) addarrow (nw,df,prior,trylist=vector("list",size(nw))) turnarrow (nw,df,prior,trylist=vector("list",size(nw))) removearrow(nw,df,prior,trylist=vector("list",size(nw))) cycletest(nw) findleaf (nw) conditional.cont(A,mu,nu,rho,phi) conditional(A,master,nw) conditional.disc(A,master) cond.node(node,nw,nw.prior=jointprior(nw)) elementin(nw,nwl) findex (i, dim, config=TRUE) jointdisc(nw,timetrace=FALSE) jointcont(nw,timetrace=FALSE) localmaster(family,nw,prior=jointprior(nw)) postdist(nw) postdist.node(nd,nw,vtype = "mode") nwequal(nw1,nw2) inspectprob(nw,unitscale=20,cexscale=8, arrowlength=.25,xr=c(0,350),yr=xr,...) } \author{ Susanne Gammelgaard Bottcher \email{alma@math.aau.dk}, \cr Claus Dethlefsen \email{cld@rn.dk}. } \keyword{internal} deal/man/autosearch.Rd0000644000175100001440000001176212101441101014365 0ustar hornikusers% -*- Mode: Rd -*- % autosearch.Rd --- % Author : Claus Dethlefsen % Created On : Sat May 25 23:01:29 2002 % Last Modified By: Claus Dethlefsen % Last Modified On: Thu Dec 04 13:15:04 2008 % Update Count : 86 % Status : Unknown, Use with caution! % \name{autosearch} \alias{autosearch} \alias{heuristic} \alias{gettable} %- Also NEED an `\alias' for EACH other topic documented here. \title{Greedy search} \encoding{latin1} \description{ From initial network, does local perturbations to increase network score. } \usage{ autosearch(initnw,data,prior=jointprior(network(data)),maxiter=50, trylist= vector("list",size(initnw)),trace=TRUE, timetrace=TRUE,showban=FALSE,removecycles=FALSE) heuristic(initnw,data,prior=jointprior(network(data)), maxiter=100,restart=10,degree=size(initnw), trylist= vector("list",size(initnw)),trace=TRUE, timetrace=TRUE,removecycles=FALSE) gettable(x) } %- maybe also `usage' for other objects documented here. \arguments{ \item{initnw}{an object of class \code{\link{network}}, from which the search is started. } \item{data}{a data frame used for learning the network, see \code{\link{network}}.} \item{prior}{a list containing parameter priors, generated by \code{\link{jointprior}}.} \item{maxiter}{an integer, which gives the maximum number of steps in the search algorithm.} \item{restart}{an integer, which gives the number of times to perturb \code{initnw} and rerun the search.} \item{degree}{an integer, which gives the degree of perturbation, see \code{\link{perturb}}.} \item{trylist}{a list used internally for reusing learning of nodes, see \code{\link{maketrylist}}.} \item{trace}{a logical. If \code{TRUE}, plots the accepted networks during search.} \item{timetrace}{a logical. If \code{TRUE}, prints some timing information on the screen.} \item{showban}{a logical passed to the plot method for network objects. If \code{FALSE}, the banned arrows are not shown in the plots (if \code{trace} is \code{TRUE}).} \item{removecycles}{a logical. If \code{TRUE}, all networks explored in the search is returned, except for networks containing a cycle. If \code{FALSE}, all networks are returned, including cyclic networks.} \item{x}{an output object from a search.} } \details{ In \code{autosearch}, a list of networks is in each step created with either one arrow added, one arrow deleted or one arrow turned (if a cycle is not generated). The network scores of all the proposal networks are calculated and the network with the highest score is chosen for the next step in the search. If no proposed network has a higher network score than the previous network, the search is terminated. The network with the highest network score is returned, along with a list containing all tried networks (depending on the value of \code{removecycles}). \code{heuristic} restarts by perturbing \code{initnw} \code{degree} times and calling \code{autosearch} again. The number of restarts is given by the option \code{restart}. } \value{\code{autosearch} and \code{heuristic} returns a list with three elements, that may be accessed using \code{\link{getnetwork}}, \code{\link{gettable}} and \code{\link{gettrylist}}. The elements are \item{nw}{an object of class \code{\link{network}}, which gives the network with the highest score.} \item{table}{a table with all tried networks. If removecycles is \code{FALSE}, the networks may contain cycles. The table contains two columns: \code{model} with a string representation of the model and \code{score} with the corresponding log network score. The table can be translated to a \code{\link{networkfamily}} using \code{\link{makenw}}.} \item{trylist}{an updated list used internally for reusing learning of nodes, see \code{\link{maketrylist}}.} } \seealso{\code{\link{perturb}} } \references{ Further information about \bold{deal} can be found at:\cr \url{http://www.math.aau.dk/~dethlef/novo/deal}. } \author{ Susanne Gammelgaard Bottcher \email{alma@math.aau.dk}, \cr Claus Dethlefsen \email{cld@rn.dk}. } %\note{ ~~further notes~~ } % ~Make other sections like WARNING with \section{WARNING }{....} ~ \examples{ data(rats) fit <- network(rats) fit.prior <- jointprior(fit,12) fit <- getnetwork(learn(fit,rats,fit.prior)) fit <- getnetwork(insert(fit,2,1,rats,fit.prior)) fit <- getnetwork(insert(fit,1,3,rats,fit.prior)) hisc <- autosearch(fit,rats,fit.prior,trace=FALSE) hisc <- autosearch(fit,rats,fit.prior,trace=FALSE,removecycles=TRUE) # slower plot(getnetwork(hisc)) hisc2 <- heuristic(fit,rats,fit.prior,restart=10,trace=FALSE) plot(getnetwork(hisc2)) print(modelstring(getnetwork(hisc2))) plot(makenw(gettable(hisc2),fit)) } \keyword{models} deal/demo/0000755000175100001440000000000012101441101012102 5ustar hornikusersdeal/demo/simulation.R0000644000175100001440000000356012101441101014415 0ustar hornikusers ## 3 nodes, A, B, C, with two levels each. A <- factor(NA,levels=paste("A",1:2,sep="")) B <- factor(NA,levels=paste("B",1:2,sep="")) C <- factor(NA,levels=paste("C",1:2,sep="")) sim.df <- data.frame(A,B,C) ## graph: A|B,C C|B B nw <- network(sim.df,specifygraph=FALSE,doprob=FALSE) nw <- getnetwork(insert(nw,2,1,nocalc=TRUE)) nw <- getnetwork(insert(nw,3,1,nocalc=TRUE)) nw <- getnetwork(insert(nw,2,3,nocalc=TRUE)) ## setup a proposal simprob, and correct it sim.nw <- makesimprob(nw) nodes(sim.nw)[[1]]$simprob[1:8] <- c(1/6,## P(A=1|B=1,C=1)=1/6 5/6,## P(A=2|B=1,C=1)=5/6 1/2,## P(A=1|B=2,C=1)=1/2 1/2,## P(A=2|B=2,C=1)=1/2 5/6,## P(A=1|B=1,C=2)=5/6 1/6,## P(A=2|B=1,C=2)=1/6 1/3,## P(A=1|B=2,C=2)=1/3 2/3## P(A=2|B=2,C=2)=2/3 ) nodes(sim.nw)[[2]]$simprob[1:2] <- c(1/2,## P(B=1)=1/2 1/2## P(B=2)=1/2 ) nodes(sim.nw)[[3]]$simprob[1:4] <- c(1/3,## P(C=1|B=1)=1/3 2/3,## P(C=2|B=1)=2/3 7/8,## P(C=1|B=2)=7/8 1/8## P(C=2|B=2)=1/8 ) ## number of cases to simulate n <- 1000 ## do the simulation set.seed(189) sim <- rnetwork(sim.nw,n) #### -- analysis ## prior network simprior.nw <- network(sim) ## Imaginary database and joint parameter prior N <- 500 simprior <- jointprior(simprior.nw,N) res <- nwfsort(getnetwork(networkfamily(sim,simprior.nw,simprior))) plot(res) ## remove equivalent networks plot( unique(res,equi=TRUE) ) deal/demo/regression.R0000644000175100001440000000320512101441101014405 0ustar hornikusers## regression.R --- ## Author : Claus Dethlefsen ## Created On : Fri Mar 15 10:39:45 2002 ## Last Modified By: Claus Dethlefsen ## Last Modified On: Wed Jan 07 08:57:33 2004 ## Update Count : 16 ## Status : Unknown, Use with caution! ############################################################################### ## ## Copyright (C) 2002 Susanne Gammelgaard Bottcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### n <- 1000 set.seed(109) x <- seq(-2,2,length=n/2) x2<- x^2 y1 <- rnorm(n/2,-5-x-x^2,.5) y2 <- rnorm(n/2,+5+x+x^2,.5) y <- c(y1,y2) A <- factor(rep(c("A1","A2"),c(n/2,n/2))) mypoly <- data.frame(x,x2,y,A) names(mypoly)[2] <- "x^2" fit <- network(mypoly) fit.prior <- jointprior(fit) res <- nwfsort( getnetwork(networkfamily(mypoly,fit,fit.prior)) ) deal/demo/rats.R0000644000175100001440000000574512101441101013211 0ustar hornikusers## rats.R --- ## Author : Claus Dethlefsen ## Created On : Mon Mar 11 15:22:48 2002 ## Last Modified By: Claus Dethlefsen ## Last Modified On: Tue Apr 19 07:25:25 2005 ## Update Count : 51 ## Status : Unknown, Use with caution! ############################################################################### ## ## Copyright (C) 2002 Susanne Gammelgaard Bottcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### ## op <- par(ask = interactive(), mfrow = c(1,1)) data(rats) rats.df <- rats cat("Draw the prior DAG.\n", "To insert an arrow from node 'A' to node 'B',\n", "first click node 'A' and then click node 'B'.\n", "When the DAG is finished, click 'stop'\n", "\n", "Then, inspect the local probability distributions\n", "by clicking on the nodes. Finish by clicking 'stop'\n") rats <- network(rats.df,specifygraph=TRUE,inspectprob=TRUE) #save this rats object rats.orig <- rats rats.prior <- jointprior(rats,12) rats <- getnetwork(learn(rats,rats.df,rats.prior)) rats.empty <- getnetwork(learn(network(rats.df),rats.df,rats.prior)) banlist(rats.empty) <- banlist(rats) ## transfer node positions for (i in 1:size(rats)) nodes(rats.empty)[[i]]$position <- nodes(rats)[[i]]$position printline() cat("Now, draw your favorite network. Notice how the\n", "network score changes. When bored, click stop\n", "and see how the search tries to find the network\n", "with highest score. The search algorithm is greedy\n", "search with random restart.\n") newrat <- getnetwork(drawnetwork(rats.empty,rats.df,rats.prior)) hiscorelist <- heuristic(newrat,rats.df,rats.prior,restart=10,degree=7,trace=TRUE) op <- par(ask=TRUE) cat("Now, we have tried out several networks\n") cat("Ready to see the Hiscorelist?\n") print(getnetwork(hiscorelist)) plot(getnetwork(hiscorelist)) par(op) banlist(rats.empty) <- banlist(newrat) for (i in 1:size(rats)) nodes(rats.empty)[[i]]$position <- nodes(newrat)[[i]]$position allrats <- networkfamily(rats.df,rats.empty,rats.prior) op <- par(ask=TRUE) cat("We have now generated all",numbermixed(2,2),"networks\n") print(getnetwork(allrats)) plot(nwfsort(getnetwork(allrats))) par(op) deal/demo/ksl.R0000644000175100001440000000174312101441101013023 0ustar hornikuserslibrary(deal) ## invoke DEAL data(ksl) ## read data (included in DEAL) ## specify prior network ksl.nw <- network(ksl) ## make joint prior distribution ksl.prior <- jointprior(ksl.nw,64) ## ban arrows towards Sex and Year mybanlist <- matrix(c(5,5,6,6,7,7,9, 8,9,8,9,8,9,8),ncol=2) banlist(ksl.nw) <- mybanlist ## learn the initial network ksl.nw <- getnetwork(learn(ksl.nw,ksl,ksl.prior)) ## Do structural search ksl.search <- autosearch(ksl.nw,ksl,ksl.prior, trace=TRUE) ## perturb 'thebest' and rerun search twice. ksl.heuristic <- heuristic(getnetwork(ksl.search),ksl, ksl.prior, restart=2,degree=10, trace=TRUE,trylist=gettrylist(ksl.search)) thebest2 <- getnetwork(ksl.heuristic) ## Run this to transfer network to .net format ## (read by e.g. Hugin, www.hugin.com) # savenet(thebest2, file("ksl.net")) deal/demo/00Index0000644000175100001440000000030412101441101013231 0ustar hornikusersksl Analyses ksl dataset rats Analyses rats dataset and demonstrate the functionality of deal simulation Simulates data and analyses them regression Simple example of Bayesian regression deal/data/0000755000175100001440000000000012101441104012072 5ustar hornikusersdeal/data/reinis.rda0000644000175100001440000000076412101441104014062 0ustar hornikusers‹íÚÑN›PàSZ561Y²÷0Ñgð vå-QŒÍh1@¶ônož×ٕTÜÖdéÒŽŽÀwñQZhþóð÷ËÍíõôvBˆÂž^֋IT-FaΫ×Ó<™-fEãÏõ»êõ"„³«×=º%:r#:-B,cœn}ûttÕ¬\¯ír—ÆE³ûǏ<Äwe–WkÏ.•šÁm+`NRN3'™S¡Ë9Hß ÷#‡Š+¹9RŽëò¿^C,·]ª>–ñº‹ãêcLlQn<êóÜÐV]úŒV›Š£ã•z(à@Nǜ ò/ÈýÈ© G"ßõ(–‡>^ÅÄaû£ÅsSðŒ àoYîiÜCšĈxè+õP<— Ö…ç ÔCÕCµ.`xõÐIôǖ“EK—k͝çÙ÷˩ɋú~T‹Õê×Ïùô>.ãˇŒúÊÛчçA&T'n¯deal/data/rats.txt.gz0000644000175100001440000000021312101441104014217 0ustar hornikusers‹EÍ1! Àzï“êgf~f¿­¬ð ²Pud«ÅÙìïô6ø™Â¿ÜÙѧÓÚ¿Ðü.ÿ3ÿÐyв$íKqÌû_÷œô]{”ù~¥ŠO›SsåŽyÖϐIäô]a\Ô÷×[åwõo‰?ð’µÎ?Ðwú«ä#{Lÿÿõ]Õþ.³c6Ø€0ÉLeŸŸ¡ÅËLö@ړá!—ýKß©{ª,Ù^˜—¬­Ï(YÇVãtú^ÿ=£ÄŸ™9®ÿ¶™5‡îYžaÐ<Ѻxý÷27ÀžÊ ªÓ;Ë{÷·tݛVâ° &YƒÌfÖ`oY¯óŒî~hîýK-­ÄyÒüŽ,ÿ®|{†wÕý®ò˜ ÙÐú*ú̈ߧÑ?¥Ž_L0÷±÷mØlè­`/(5óšç¹tVÞý’Ÿìc¿»6u4=¬6Š.M…¥ÙÆÒ{Ñ=èà{Gl¢é`l[—Ußø°—löŠßi3îÛ^Ð1ª-GsÏÛ §:Hÿ,Á¶£¶–- ÔþNcޛ°¢‡æí¡su[kÛoeº#Þéˆ#ÿ£BßžÕTا“Ž,ÅÙÐØ5 SF‰¿Lþ oÛƔ‚¶=óg6Þm„‚µÙïî¥($Xéý×ÞŠ[HžMj–¡cCßYi£çŽ=hòïÍá·ÑÌe{ÐGx†öxZgסÁfÖ`Ï¿¯ªöQºýÝßÖjÒ_r4»a_ŸØ^­_ـÓ!JÀ•gÀu&úyî\ᇜø1µ=ä'“×ö‚n°“ÙÓd“w'°ÁBúˈoãï°áÊT€üœž< “-¢dÞÈØ ™zhSóÜ1wò|¶­ÑŒßÙž®šÏ¿D§¢œñ=)FDK[;J/YÍđ5’ˆ'‘ãçin€ÈK'Óð—ŠxÂ4··jø]fœÌ¶ÕV nR3ˆ:ëÁükyû4[Ž Ïl?zygJÝòV°¶=ݹœTIö±mÆ×DÜЂ žgLÚÎ\öšãŽ7Ñ«7މah’úŸª8–ÏZH2¢XþõŽ€áNAe\XWoÛѲá]Áöå9[Ž:%cwUhœ¯âÅŒè/ Â'Kݐ8E2ÏoÓ€gbI¡[]PâJµÜpD†CA]öùêGS&ºÇÖWÙSzǝʞô¬AǪÕÿl¶^“!шt@ÙŒnv|7GE?26ð|_Äÿmêœu6Ój9 ’`"¹™³åöŒmHŠÉ™ é¬*tôg›Kš§ò; ó{€MŽñ­PœII‚žîh ‹Ãoëل¬œÐ®|YÜƏuɌʖ sm& š†Èÿôó)1‰)ŸH;ì™Ìì;ÙïLgÿ{KÝ뗠rŅ»•sŒ Kéö–öXžã%˜âe^J€žØ®øÆÆ) E<×`š(¶®ÉÛTI~ …AéQŸ¶S­Á<™ë'\oÓø 2?Ké^…Ï,vEËtzÌ3ÛÛ0Wì1ŽKÑ@tš"&æS¹D–Õå!CdÜš¶H¬ŠéÞæìÉ ¥Â6r72*5!`öÓmÔ bGånE˜FáQ8˜b*\Øå­¢ÎÒ§XB‡ch3&q|y™:êï"pz®‡é EJڇ[›Q.¥uèü³£ÓØ,*E‹s ³Zám\êèËÊ3 Wn³^ǔŸÉ‡'ö@Ùöê7—æ;%œœ$CЉÅ;Õ$ÓÉox©Vð+}4Srý{âäœZݧ³a5 °Nâ”Àc43ÂNµ²Ð"œ ¡¢Í+pEþÇÁ¥Wžb«Ïsj¡8£ J ŠÍ_( õ6†!ög¶5«¢§§c¥+õÐõ®M[&d‚.ºÙ;°©É+rœtF?¥Á@BR¢ž{>z÷RoÎÍC ‹¶o ,ˆ8Nù AxfèLulÑ>¹Å`¹:)ÓF®!?)〬$\2]Ïñ«žSªŸk8&Øv}†Â3u¹¿ÍÚkcºñÓã¹áÈÚpÅ/†^Aðlh‡=`nìQ ‡— {PƘÈÒŽ«! )B·ÄŠ¢Øfš«+v°]&3}¿~6AÞÆ2Á‹y£Zÿgî˜&±=‘¢#®ƒž<€d°\“Jì£Ö‘am’p ùËÎÅ%ÖV@˜€“qVÝ7†_V¬<Á¥dûS…a ìù^†uÎ,ÉÙjR,«i!ȲG,\pÓŠ¥y9íoTF+ÖG8NŽb¥òq–º5³í®.Ù/Ä=@¢¡’Ó‘›Sú~ Aòîyó¯8€œ—L¿($u^…ПŒX¢º±Å(NÅQ’T1( êž›çÔBa¿ƒT­VºHïö”ad¿<㊌Š£Â3ŽjÇ4tíOšÒÞnîš=‚‘™M‹ªÈNß nO¯’®ØÁôÆò£'–œœ*Tõš³;ÙT¥}‡PPJžvÒnãXÄ.Ö$ûs|úCKš>•lfÖ«uÚMÈ WœcgŹ°Ä]¬1ý]df¶’+’qafup(Ù,²ˆR·}c!÷eög"'m¬c D uÿµKÒ^æÕÏÂ8…©1sÝŸÜ‹Aãç˜ßŒb0~ Ã0NŒPX2§øݗ$¡ô£œC²C³K$墇² $”ÔLªÆ¥Ø•BÕäŒvŠ@ƒa# ÛŠÈš¥x¶ëž·€~ë³RÅÊÔ "ûD“L`-ñ—»j7–P¢Ó2  E§ò í^]“å [£87kªâэ] s”o ³‘ÄÙ³ ù© št ëçN˜4·ÀÅ@œdþqÈæ‰)\Žv¢S±ØéœÌFT­?RªžSdŸU&Yʶ3M€{—§.rûNèm^×/VGˆ;֖Ւ*TÂY*­F }òdq«{ëì„`ÏbERtìÀ\œšrqP›Œˆ˜P'œdOÓ¬Cú.$õÈôñ技\Ü€Él¹rõÁ‡+C¹“à`âg°JÌ&8ÆCO#¿­¹À‹A…gšŒ 7[7™&2a,l%[œ(g™Ò—E/áú‹žr)šµ_P©Þ„Ø^ï(ŸU\tƒŽ%^²—ÓlHö6«Û5íkœ£&²Tø›ZÖÜI—š¥ú ÄAª7‘DWŸäýoIað,so’•‘© ld–mYŸ8Œ‹C”eeõ)M±± •·šÂx¿è7Â#<ÑB!Ôy:#_֌ÛæŽY¥< ûÔÚ~²ZºšÒní3;è©z}v.‡5àDJçÓQYˆmÀ Ì2Xî{€ÁbY0ÎÀ9)š6€ÇÅj²EÅôsI4³é?4™|¶ Š™² š¬œ^Jè€Kglœ~.£×?+€Ù6;œ ó þ›¿sÌKäó wOï?‚_6µhÍ,4tkâ±Åïl®T»óÈpØÛ²ÁqŸï/ފ‘•û’œö`G8uOŠÚSԔÐnQ§bÛuµE{ëIìUC7t!UçïTïxq ˜_·n ãCï›4*ЏÃ<aô ú‡9|;ϯ\-Õ5Œ%Ä쓻TO¬†õÃe­4=bÑbæw‹ñáeŒÑÒ±±žôO Ëëº* ë1šÅµh#² D~.xJ™ƒ{ïs˜Ždó®ŸS¬Ž1âTQˆ¶IÏH|Š4Ù¬ pŸÅ©üL6+€ïð Œa‰ƖéÝ°6À]F®o'TŸùh†ÓšþŒ¹+i= ûte³ÝnùþRÉïÆ©k7ÃZ^µÅ?ÄÒÒaú‘›Ë†(¡—,%üúfmӄç›(DVšÐýC§WÛú¶®ã¥l9C9îvó·uEöQ*›:œ.î£7i<sQ։…’µ á6PÏj~ 5 v#§UÖÓÃý¯òŽŸ©ó©j¥›9fûeräGÂ¥ès*~çVý\ Ã8Ê*‰Ÿa qäú[ôçlOMÚ;ÏÔr×þœyŸ—ÿ\«ô4Œ;ÇlTLN«GšF^W,Û§ÆkH%Ÿ kP[K@Ÿ©©CÒ&‡3hv…d-ÖG嗷qoÎðš# …Zњ#<ÃõÃrÏÃaŠb,Œ!ÍÙ^Z†u·_ äàþº¢HÜ6›ç8Xñü|EÔ3Ïi™ð‚1³Èž "ìoÚcþ„þœPÚUÚ3Çs~,EhgNR V`žÜÁÕŸ0VÆN²MF58ñ‘ «\B;2× µ²ôûKvã¢RcânïÅ^m®Ú‹ž1mj&øl"ÄÕÓ2µUà藜…Wkâ=]܎ù­x«.4Êîoaw`«òž¡Ö·]žán™1Q\œÉMéCíŽe¶ŠÖLŽExÌÑÂa­ÏDÍ4òÓ/Ïê9E‰ýòÜmhíi€5œÐ +º`×b”†+ÐžÇˆÒ²=S sdi«ùYÉW&²šõ|‡÷MÝö€Íë«0MØü‘€Ýð—šÇú6™ƒo7üLH¥žéŠz‡.@±”fâ¥×w÷3Ãðœýb&ã]ëÕè Ë|NwÖ`SPfaôšÅJåš«p×br{Ž-}ìB;*ó–ÕtûVޑÜéFPÿevocÂ#èË3“7™`)3hŽ÷mœfعªCœÜ³õÐÝÞìþ–è†×oŸ®Rò5šÏÙ!–O†Q¯|‘)‰‹Žx„ûM§å&pcp̃îÑdu$z–cU' hBÉi3Qîqp Zq €®YBÊ³¥£Y0Aø ˜ù|¿êÉœ#÷:È¿L±“ƒäz.›Nä™ýõ¥Æ·ŒoO¿3šœÉ$5¯$€>ÃX¯K8™‘å™æCƒð¢µ0éJûŠ‰ògÐfÉNe†gššŽ,Nèá&;iBþ¬qÔ|é„Ážõ·B]¹íë€×ӆV®§™ÚkÒíx›¥ çj·©n‚ë”ã #fdG ä™ì·}ÝA›‡†vh7Ð)i‹_ÊrÆFnm܈5ãØrªå®)zݱ-œ̟Yç`B‰š¹úÎœÜ/.›àªv4žŒß÷n†•ŸFùȶ)γódë-ž°¥í|(G­Rq…šÙ?öl©éìa×VgØÈêèqúLúéóÙgD+üy»:U͑ÐÊ:/oÏ¢8,:›†Õ:d Çã ".äNjúd&úù;y:¡ÀŒÃ8ÉEü€„!×õ_z7ÔRì8o‹Áhг,=Wë5k³‰ðiû<Ý8® ž€ÏôXŽÙxIo¯©4Óoêp£¹(1…¿»…©-ZŽ‡gŸ Ú8ËÖ¿`ÐÉ]šÛí`?ç±3ŸKðf:°r_xnQbÓ|±øbä4ÿ$p(:µ„‹jÉÛúšbWÜjC(8ã‘cÄs $7!ØæŒx?˜MÓ¯ÿi1æðùJ»9,Åsðæn7°œ9 \ê8-``ébw)a`e„ùbŸßÕÄ;)ô­]ž·—µ/P ³Œ—¬š5 pÖô…ÐQÝÌJsªx·ßÀŸ~s ùùîñÍôÉv槩g|ˆåHgj3®²,€;ÔYLǚá÷ÀÏ3¥Ÿt'Ú „ Dô;'ªÌžîžQrŠÒ®s À®ƒx†•³gµè靌ðN5a„3ÎRŒ—”>qOü5ŒžŒ fÐíYÐvHñÒÚÐå#§¹ƒâé …óé—'Dg ‡ç VÕšÊ7î›$ Ý.~!Ï»oýû‚šò”mº\z¥›J zV³j{ñ¹ÜÐ>“tµ(áè3¶k&•¹¿MÏXvÈíÑÖÂr–XŽ·”É-7E¯Öã^í#>!¯ù(:Ÿ©±Ý1ŠLœ ƒ¥õÃþÏyr{:ÓTÏñ‘QÕù˜_”ˆ1‚Jµ|²D$ hŸé|†_7Ã|Fy?ää6tŠPM­ Öé-&ᔅ¥y>ÑpŸWáË.x‰{ê†éJÌdkcv›b­Qüdw^Œw¹2Æ5ɲæ <~&ãÛ²âeƒôfºA{ô±­b…È]GüÐ?” ‚Öƒ’ãÙëq\D4ØÐõ8bkžgÍxØ"(_ t`Â‹Õ äf«¹‹ŽØ[ð@Aó!ögxÐ+à爜Tjmö ܃l¿øùëpšGƒ˜=“1$ ÁòcÖe™.H…™¥š­«¬ËÀqó|"|q-fcnõÉÝE”HðÅ°×ÅA—Bó ËÂ^ŠŒt¯:(u`ӁŽ%rú‹ßƒ¹—  E9ÌHWá‘~rzž^Ä|Ôï&:CËù >’g ú¶v²c8Я{ã'øltEŸVæ°âïžQŸÜÈxLYºÛ­ÈÖç ]ó Æãp2&ž‘{çzrãéú蓚cð• …å0MpiùeY: ®¶Ï.P9>Ø Ý±]Äï±?SáƓæê—BêëúÑÉf,Ç4x €˜çcõ#h.1ËzCÛ ÔÀóÊåêHôª«0€+(ŽØ}oÐ5üâùài%§›€2pŽ£—‡@bÖôu0AƒÁ¯Ž—å‚‘? YÞ +¬CÌæ™ 4žGm$wE6ÿÞnªk6ÚÍs'l͈‰6Äé«5ÐÃäÇÑG*:Ü¥‘ŠrX@0SÔG@CG§l~ã^ ø?ŒºŸè•ãý}Š¡þ8*x`pï˜ñIš=îod=#àR‡Ç]„ÒMžgÞãÙvÔp°ß‰ò#ýd”Û;,ýñL/C’Cþ2¿æõPr‹Ùx‚UN$º!z*éqOÖ#Šn8üÚ,б] IÖ(~¿ÃÏÔb˜› úPT šíƂß©G$l±'ߟCf‡Ñoôœ‚w”Ø„Ò)ŠÑørš/áåÏ®vÑ%Ÿö²'äæÃq_×¹€£=Òû8Q"érFç­Ëæîu3u×ÉbýŽô\±£î:"=˜g¡²ÆCðd§5“·ýŸnuÃ;€·2ïµD†`(àšfMšõS­˜¡—kÔó •‘ìËöƒ‘ÕÃaÖeÅgߪµ‚"Ëo§>7õ/'<ôªÄzN·Î=t6îÔY*…‡¯7CÛa²|¯G\f˜GË¿ùN²k¿%ÅÊW)"77<ôNqƶí :] öG\øò{|èX‡Ý«jŽí6»ò A"‡_~–F|h xaòˆi d-~mioq{úÙìp AÛšý’f„w:£î^Ö»^Úý¢§ñ|æ$ü ä[ëžљè©Ðž;ÊtKýõ€|š8‘Ÿ€œîÎÕØ\y™ôÜv1¶<ų³ZûÑb„qךp•[Ÿ˜(0Ճâùمȧ*ìi 81€2°)“žÆ¢x“‡y°çní·b± eœÍõ^„^ÿ·ÆƒÏBS QvaYEêjŠ§æØ%DøѺŽ)`mdeal/data/ksl.rda0000644000175100001440000002536012101441104013361 0ustar hornikusers‹í}XG÷þœÈœ»÷ª±${KÔØEŠeì h¢X°¡(J Š ,šX0bWÔX‚ÅF샰kìœa¯ÈïìÝ3³÷Ë?‘Ý ùŸüŸÇ<Ïq÷îÎΜ9ç=çŒ3»š¶ ;U–:IƒA0å?å?œøƒœ "ý‡xß¹àTþ™n»Âq(È{£ õAÒ@ÆÃS5áØd È}e  ) í@ƒÌƒ¶V8>9òdH]ìÚނ\…¶²ŠAÜAüA®(× ëណs”gHI¯@Ÿ„ßóAŽƒ\9’²_Y‰ºŒ‰Ùâ rä.ö] ŽÓ@‚Äâ¹<ßHÛ n ‡AFc›5ø[¶Ç³ ç@ƁìÆg¶l…Ÿ Ãñ˜bG’Ž 1š·l³dp¯{ÁÑŽmàXŽ×±ŸE'RZ™ƒmÞ7ðúbœ×^[ø{=^›Š×¡ò5 Ýåq' =Ð/‡ýIYŽ»lƒŽ «WŽ©Üg_|fH7žWm?d)Ξ#€#Ð0l{O™«aŽ›¢øÔÖîW“8‡de,òâo Hü.…ö؎m?(804G_Gc{ùÙ p\ŽºžGŸÉzyÁœº8—pÔg6HSŽ]è“ÂÊØÄÇgpˆöðEÿM9£èEŠc?Ð'!ˆÕKØÿFì¿Èħ¬çHÄnŽbRý$c/õˆEÆà\Œ°ŸÞ8·ÉèSÀá!HšÒF¶™ákœç>µØßDWžÃ;ۄ:ÏÇó%h÷UˆéÔá8Ž¹ÛÇ`LœUÎmúÃÉg8‡ˆ¥šƒH`ÅŠ6[Ãviˆ‘«xó0Ä!Vå1vá<}Qy^€Âxypnmp~}Pÿ}8þ4ÄÈAœO$êâ…ö>€X4Ã1äÆk¬ÒÞfïã8g9æׁ\Æ~Ž nrŽ…÷}1öÖ ­ºáœb°ß%†mýÆ¡ßVâ\ŸÀk1xmŸ2ùNŀ-þn£®µ0ž–`Žº…z?Ã93ÌÊ96 _bnñB Å ÞKБŠl¶èŠÌG¶/¡Jþ·ÅùØîêñû/€~‘}à2Ûö@Û-Á<ÔmQç·L© 6?ND¬Ê6h‰ºÎGlÄa,…+ϐlˆ³DôëÌ‹ð™8̛ϰßXŽ©êóuLÁö3TŸÛü= í·ñ”‚ç‡ÑÇqì68‡-ˆß8×%xÿ6ö‡íº¡>˜[Ôq4>ã…>ȁ}WƵaç!öÓõ8Œ¹ú,êÆêæYôá2åŸÍVòµ‚8vìëbükÄèK‚p®‹p¬FèûD¬=;1·Çkq8ÃÄ)Ôe-ÆÇaŽïhÿ=Îu4Ú%q†qXÐ.&n£mb]± ž×¢¿eñPãÖöŒ±ì†øہ6ELØ|Šù]@<¥¡­îá\ß ^Ì÷Ø·­ÍU»øÃزéúÎ㎋’ˆöق:ÄÚÅv,>‹>Œ‡ø«†±ýçÍ.§ý€:oAÛtC)‡ØŸ‡ŸzîFì3mÏSpìP”Sˆ9œæwnâПM=ÐFQ‡ÃˆƒExmê± ûë†c,Âß!UQW_ôÕ Œ…ŽùÌ}ñ÷CŽÛaÔe%ÖŒƒhŸ‡v9'å¡]œò@^•mÆâ<ã9í;ǜ69…yt%ê¶}ÚsXUÄÒl‰cõ/ûAŸ“êèÄ,‹û_Pÿ—šû^|þ6æ@Ë}y Ç9ŒXh‡Øÿ"Ž¯rœ1ˆaäãQJlÛ8q rßvîzG!gooÇ;z"oTr¯­_žF*a›m˜/"1WÁßì™HŒv uىã Ä6cìƏÇk;ñú2\?â±1>ˆ:zàùNì¿1ŽÏÆãýÉ(8GÒû‹D~óŒµ³ÃNÔ{êãÁ6ÁªŸl1'çÙöõPÖo ŽY ûéŠíX›(üýq˜‚sÇãx·5>‰>êù§ü“ Ïwâ3WñØŸcgãDœc”Ò7qÂë;³yñ÷6g ê>ÛFªcÙÚ&¢"ñ|²Â¡l÷æá8·0Fv¢ŸbñZO”hŒ×10Çe2Ÿƒ>TígW¶]e|~2ò„evXcŸý_Ž[7Æ#竇¿/¢n;íæûS;L7Çs"írJŒ] ÏßzâøQv±Êb)uTlkkÇðššbÇ{4öÉ®TD֟È܈­o¡î‰v6šŒógãជpòº°d8Ë@[ÈÏFX¿ À‹˜«krŸüYh÷€· S@ ž0–±-pA^;ÃÚ@3áôC ^ ¿ÃxÀó…N °Ÿ€K à!ÖÊ€Žu‡óÞp„þ ąPd¶ù®{‚8ƒ@Í€ß €#ðxáÌQh˜.ãïŸ@ >!·à)FšÉBEX p®q^ò=™GÅãx®ÊX¶û¹à<7Îð#lPlB`­c4Â9¬…˜;¹¡Œ'|§Œ'¬Åç3ÂRàåð3ê”õ[€:'ü†ºRú0ÂøFš«B÷[8öƒþ’áøDië8!;±OÀ™ ÛÎM±<@؅~“û×u×чùA@#ä]ã¯pQ¬ØŒŒG=š€@.žÂµçp ÌUÆ3քóW G?Ûì'ûSæؐ[ÐK| õÑ¿áàðnÁ]ñ7¹Gy.{ж¯•y8•„¶Í@ÂoX[ çÑÇ.ØøËø€ç 1ˆ!àL‚ÜŸ;Úo$Haãút¥‚ex ±#@¬0†\C€!ÀºL~%D*˜. Nƒw5&ìµœ0ò“ðNÁ§|ж·(ãxŠ¹Á(ïSUü!G ~Œfô!Þ8WhãTBµ¿M·qš¶±ízýO›ÚÆqÃg°_nÇÿù›œD;ÅûãìÆz„ŸßŽc ÈײPõŸíùív󪡎e{f)ŽóÍò5ö¹çóµ]3Ù遞bxŽÍÇî:×vîø ÃyÅ¡èÛµ(쟝»Úõ!Û4 ŽUÃÎöavm¢ì0›‚zDÙa$JµmÞ&Ä,{†ÍƒÅD^7©s³é˜t’?ííæüçèúŸó·ýö¶ÃÓã‘]¿ÐÙ¢Ž) YˆŸ ³Ã»É.6|£ÝWñe‹ƒjlÙúÆØfö°É8õyn·d;?ÆÙµ³ë×ínW5pÞíÕ#1/ÛKÖCîƒû€œj[ž¯`L§N*Þmí–âœ1ðï<È_ˆá/ŽŸŠåúŸÿûó3äožÿ«~þ®ÍÇt7|d.†tôÔ2WC:6ø«ùþ}ÿnÎé鞞¿Žèò±ë÷шµû»¶zl—žý :t5hÐ+=€7ùÞŽê€Õ>züŠÏûM4<£uîZìG҉ ¢c\¢¡?=vL/†Ž^#:ò’A#ŸõċÁåH | ù‚hš5 Ô£§!›hՙh¬G}6pD¯ôâÖà~ŽÔk­±mИ>†ƒ9Y+nµæw=Œ†h°ŸžH4è¢õšVN£%†Ó«Íz}ª‹Z棥Š4ÚO/7ÕS«Ó‹_­÷õætœ8×ÃOõpm-¶pύý¥—/õ›–9káÕDGŽ!s†_hÍ!ZãWÏڌèЍèÈWŽæ,=ŒÄ®£%7éYç9—õäµô|ø1;e“÷<št͌޿µœìj¹^v-•šìuêyz>5?™ºu-DÅØ=±5‹µ£–ó¥GkMÔŒ!;xzã×u¯~ŸJ¹îÕ^›“Š}ºçŽ:4žšBz»õŠñ?{ŽžŠEï/¹6n •.}õôájnӇ›ÙJ¥ríü€š£§÷ûqPµT ï”pq%»tëÜh…5­ÊŸûôÍÚeföƒ›Réa¯Öæ£æ‰ýœ_Ÿu§Š;Ç×I­EÅÐ>]­m©ø0ª¿XŒ/Ýö춚x¿zÌk73³ú÷Þ»ù<¿ntí{ïŒ@Åæ¯Î|Uù<øs8ñî‚ã+[ܠ早¿m0”ZZd[þ€MY*~纥CŸdjŸÒšóKûPñyRýŸÛ•¡æŽß*F¥Yþ^¿œ9J͏wMúòt*–þ#yሒTú²ŠgÇŸÔüúH»±Ë³Rqëå"MCªQiôːVcÏp»XÆŸy­g*}qyIHÍ8*¶vÒÛR›šJ˜²éàE­×² Þ>„JŸß¿mÁöT ó?t9ô *ÕªÑ=×íÔüÐyô\Ì»u‹ÑãÊ\¥Î·^|^/µ$/…]^;h4O̘þ:/5‰}s|O³îžœöÍ_©yQ“Á•§]§b:oî\/K¥‰_Bf姊Ðá+š»7£æQÇâ PóòãKÞïDÅé»'?NŠ–KL2Žy|»~h‰`j ýõ7ÿáHŠø}v×{õ0܅Z|ÂÊ¿ˆZšüÊUI£âüm{¯ÏžFÅÏJŒ,|ÚMNZÛ$üðeʘ#MüT¿ê6­ÆŽÛÔÚbWŒ{ü êŒR˜yüB[j­8åì๚8ŽÍõuÁ®ÎŽxþb5׎«Ž"®w=Ñ»s—4«ëåÅ7RñhÛ­M✹ÉsBdÀ²}ÔR;éIÎêyh¶CVßÆýdÞò«Túm<µŒô:QrÙj^ÛŠêÓ+A|R³ï|äþJùŒ%ª{•£ÒÀ݃]©XìX©äM‹šøÍôyG%¯çÛŠ„¥ÒŠES »EšøØW;üLÈ:*Ÿ™ï: ü,þ˜wÚÌ£›9.-[ŒYp-•Jß%F’Á»šT{¿iþ÷þÔ|ôn‹ßµ¢æò'·„/*O͹~›wÄúœZ©K¿j?Î"6\<Ýôµ€ìUìC6j~ߧ¬„Djn×ɳ¯>ï×\ñø¶) nq{0‰skTÛ۟šÌs\ŒZ¹Qɺtcÿ„šK$W]Ü߉dz©ZqnO¯SóÀÙeî9…ÿ?z‰1~ƒ"öÍ¢æ¿T{r·+µÞä;“šã»:pÊF-Òµ’ÜyüIk+¯rÎYšZ†ç¯éÙî1µVÿðlçžfTlöCÈßçyCú¡àš°ÆáÔrgÙY£ËH*m®<Õg÷·ÔX×AwˆŠƒƒG…üqfïõb¿ò+ì3‹ç#ñÀ7»'-xn5ðʼno ©Ç39<֌þšZBÜݖ%6¡bŠ©•Êš9ªú՗9WšøÄøµHVǗ˜A¥ÈmUŠbZ¹œ{Ÿçø5Ÿ)0»ÒâMjþ»ŽùŠk)5¯ ý¥~qƒ¿;²š»¿Î¹°`g„Ñ/:óx4׍ÉZâe%j±6~ñy>Žé|÷™çSzQ±føÏ÷šžý­ÏÏq€·¢‰¡¿$€b¶Î.{N€–q‹GO+O-KVæŠXŸžšw–=w³äQX[nþ…Z:”.wûr[j)”v.1  ;‡,pËÊñ'm~4(eÕ*…y¥øuú@Í=ï6˜4å à­øS‹öTºìrlî։TüµâñsÑà—v O•HnA͖¥méšxj^v¹RZûg0ï/~l»p.5Å.þ¡ µx_-å7ŸZó,+6}Æe*•x±gûM#5/Mp nƒ:þÙø)Í A¿Î-žEŒ€bò’cqûQ‹Ñ%$©ԍ‘§œt†ñ~ݺa—vÏÙn®‰J&$¿ÎCÅ#³NiIMç:-¿T³5µJŽêžŽëÖØðÏy“Üj\s0†c:8eɃ°ïÆü;n¯‚ùì6÷êpòAjäÅ AWšxsNŕÛÎRñÜÈÒó#QÍsWŸ”‹J5î\°¬ºMMîÇVw¶ŒçyÚ²Dè4gê*Ó<í;ojι-KéMשéUýaC®OçùƒÝgžeu’Å5Ï3áç›N}–Zžt›jâ~–©òC2Ä×ÃNçŽC¥_ÊܕŠOlžÓ¿÷‡ô}¡:ß΢ҏ¹åES)±SñŽkò«ý~årŽjBa*U8Ø%;ä™è³‰+çãùŠáÏŽ¥OÃ…Õš˜è2¶µ9‚ûÇ<8xZïÒ7©r»Ì‡Ô|iŒ©íó&Tñöh €×g5[Lys…JÍKUicPqÊ·÷Žù=šTíäÁÅ+Æs¿r|²z°e‹G¯qԜ²bíýù¿PSRŸj¥Êo£Y]†]­ÝêÀêQÁÏ»RÓw Û|#^ Š“N­«];Âë¶è2iÞÝÇ'yþG›Ý~|ó69þx±há»&Y9þ,㟝rè0¯Ï æ÷÷÷4žLÅ=¹~izŸ6gm¹–Å6•Zx ¬¶6ˆó)ç“ÐFèuóàû‘ËQç¡[h«­ š¥˜ïҘ¶±*/À8eùY~tφö¹U°:ŠøgüÂŒzð„î!“xž±鐘V~•¢'7nõz:5mœúyÒÉÔroœùwUÔü¢ü™—þû©…|y¥èÕ<…õÂ|·ÇšW!yxüHK_–šX”ŠyK{uŠºN¥óÕÊHâJjvwÍR(~<Ï÷Ì/æ.¥Ê8“ZC>˜ãë¿Qó!ÚÏŒog%ÿ͐'}ÒåYAMÍŸNåúµT÷œrÒï>µvŽìtëôc*劻™«ÅjºŸéqÒëáT|²Øéxé•Ô4þ·=÷û%ðž}ªùŒHiÃù˜ØœGàì©?R±Žµ‘ÿJ¥†ë𔞜,mô_Û+š'uíÐᇙԲûüÔ¢KÕúrÑ#ÿìÅÕº7=÷€ýN>TÌ='uvÀ*Fe›wsöpjž]ÛŽãêüÃçy.3ªùìÈg¯&=­A%—m£*„¶¢ŠuK<Âë„ɘº±È9uŽÚ»¡µ×ÀY³›#݁ŒtºÿÈ73©8.¯ÿ»Êcyáüavø®ºSQÓ [e~ŸîJ-['œì·ÐšJ,óüus®õ”R=áè‡ÂTŒðÀõmàӊV®òù*6ÞÛae7Î¥:aµ/GþýÞmØD­Çc΀„äç<€ûŸñ¢V}k€x|íTã©øµÊßn•dIö ŠUET\ÈãY:õ`ÚŸ“‘4kõ#ó“|š9,ÀküXàA;œ[ҙ_RñCw÷±×¶q~+.-Ùáéy•b>`|˜åVÏ¥%#â‚cEj-S0xӚ~*/güþ‹œó³lŸÌëŽX6$({ÿŒ›CcŠû· ¡bEsëy€'×ÞŒý°çM•· +èöºvsþ·™²»ïŽwŸÁ@þ¯W°Š*B¥éáçzçšM¥ŸÇ¬ŠÌqÇxƒt ÷ê~C©èœbxDÙ7Ô\éØÄÝ©¥ÆÎQޑ_ò|hþcp|©ž`j>_§/š5áPèîóUO«PŠgÏËjœ²:Îê=ò|V_€œ¡[ö à~°~[1±àœ<œÇóüi¹1öÆçÔ<3ñVš êaö„šÇ>N-íJÜ8|žŽ:®­ký>+sz ·çˆ;[g4̯®ßÆ¥”£³ïsžÊóH­€˜Àý°ŽØ”0éð¢…êúðæ®Ê!3j«<áE©„z“ n­¯8€a©rTô]èSºÀ+ŸÞfuƒ­3¥Ÿoœüòñ«E÷*»SiډŸò†žäõÁš=GpûÙOŸ©•÷÷.*¯nü78²ž‹ .Ÿ>×EÆ€b ‡Ïgàùñ\sð‡*¡³ã`ÝòÒ­N˜ ç= l]ËóڂºæWóêQkË ï·ü>øTj£]§WSÓîzƒÞxÎâùÔúٝœÁ{7Sñ³SÍ}¿©yó¶õœÿý°Â[šŽé](à՜çÒóˆ6*?ª]vNjþÀ'š…·z™Œ›ŠIIE~=Ý\­‹ˆÎKwŒ~cŸ28Zþø|*+Ïå«hž¯x=Ãý^›Œ­pU*î828e=¬ËΚ&e¯°FÝ1å7yÖ[ê|¬nÕ€E¯¹],þ¥;E€ô€–ßv™oêÅy9÷7®G¬ƒ=ܲ?;ÀKŸý|/%ßQίyý~Vê‚Ë݅ÔzåIÒ¿=TúŠo@×ùqœç2ÿX ·/˜:òlÕ>?-›D­Æo-Ë~‹Z,?Ï­ ýöœÒoâKjõVôéE,w/g'ŸÞaù‡å[1Çށç÷R©Ì«©y5àëŽsÌßæ’ÉøAŒx6'¹$ð‘ñS….ÑåšiOË受­áöe8e8ay×R"dNäÔµ*_zÚáêË …P>ìt_R‚J£~1\ÍF¥ŠãŸ«3šó+KXœ¡œ«æóçëý>ׇ{Tÿ¯?˜_œƒ=ZÛò}ž <ô_ärœŠƒ÷G” ËÆãŸï+1~ÎöK0_ðuO­mœ–6ÜËqmÚŽiã‡õ£š)µgêÅÍÛÕz€üÕê~üEDù¡ŒÞ3^$š4&m¯•‚F–8<$A;Ž× ëŠétMi舳çÎ'ÞàëñÊþ²‡gÞSù-ÛB^Ëò£è4êኣƒøúÙ‹ó©6gnS™šÞw.Õ]NM1?Ý®@ø>[/³ý4iûokzäöàüÅ­©O1ç*ÑWšyG{;Rjq \TŸºïøhÀÈ­®ñ:ÄêŸ%ì®K•åfŸßÇùjÓé7퍂õ‚åä®"MÕ}ŒësV­¹U]õ š±ñ~ejq™ëýMñÔžèƒPjj¹5çÓK8¿’Œ\~,ôÅslœÇyòýª-¢ÏÿDÍ?_q ;ÿˆJ7n”Ÿtè÷Û'£®ÏÝ8ÏC]§5™9Ð0ÔÁuǎ䜕š#ømžðŠJ· ªß‰óc©~÷Š[|Æ×cŒ¿IáŠMŸÿÂևlžñ 6?ß,O±}óñ=Ugÿ ®ûop¯q\5Ýã;(ÊOÅ{?PžAÐŽð5Ôjñ\SÙo¯¯|ßû3eŸ;¡ Ç'ËÖ\]ü+ uVù«Sª9;m,K³>ñºñƒÿ˜?Ø~ã#<¿Ä:× i*Ï{9œÛŽUUÍöӑ÷š˵aI=ÎKùŒØ>ý‹\,÷øŠåç§FµÎB­E†’]Ï©åíóýšJSךßE}ÿ°³|»AEŒx¯§–3ÿ\Ý?Âõ Ûgbu‚ñ*¶Ÿevpþie¡ãB?•×ŒªžoyŽ±*ÿ7¯[ž(‰ÇSÖYUr€ÕjH­Ëî/Ø·ƒZŠú—»QŸŠ%wß7™Ëò*ó«Ô xÚŽ~<ÎØ~6ËÛ|}Q2h܉!qêŸã›ÈƒÌŒªùÈó×m£{7ævoW¹êïî§î·ñüJ<¿›š{]]{ð«1‡l¿ˆáŒí?3þc OÒ§`)îgö>DŒübëžg<ßgsjRý§o:ÁzõnÓÈï¡~}ëä¹åm•ß°}Òe—÷•ÝòšahïìƒÔŒÅüÉx+Ÿ'‘ö$œHkµ^Ý׊vº˜cª¯W¬ŸH;oO9yŠ³º…ë ¶mi/aèà#õÂ|»»ªü×TÙy\^Èߕ£o üpìºYuú«ûzlýÊâ×­¢euˆií j)º×Å}H¥UMšu­¶ŒZVmìœ{SÎKغß«±ù°}Ƌø~®?ÍæÙy“Vƒï)Ùþ·4ãÀôŽç[ªöÆu[wpþ‚ûìý˳ì} [Ï°õßÄõ€Ž&àAÙåÕ9þغÃuèeÅ1÷‡¥Ÿ‰­¥ŸÇõ˜ThsÞ[ñõUþÍâ“íÓáu¶e©é}íɗ…ùû_‹kþj øòõ«gÖ¶üßvæñÄ×·øލœÇãï+qˆáÞòeàw KLåü”ñUž¯ØþNïñE Š¥Ö‡_všV¥597/7PqÌÖžŸ…}øûG)åaøÑÖÇ©Ù3­ÅÅùµyàë:Ü?6¯£×¢ u¥– #w®zu2ÿ€ˆøäQTìäý¥\'Ô},–p]Ãö«¿Ÿ¿únô°Úê{‰‰-‹÷mՊJ­Sªþ^ô[µzú‚]Õ}È3ë«ßÙŒ÷Ç÷ð=<ãy¬^I—}Ÿë³Çê:ó-çûŒŸ"ÎÍçíÍçݒï‹2~g)ž°ÍÂàG|žø~È`0Úÿá/„üéøç{áoÎÉ_ô¡ȅµ!éè÷Wíµ¶ý;‰ýÓÓý¯ú!ûÓ£»œ‰†y :|'üï?†!=8Óڏ S_’ŽïˆF]… `,œg6ÿ;Ì€7.Ñ1Ž–ñmF4Ɠ\êÉ ŽèŠEG¢!Ÿ¥ç¢ Á’žy“Lê—8ð$ÖbGòÑšÉ` 멵Dç5’NJàÛé¬íþãåâìÝË¿—·ü/Â~fk¡\%•ØIå?µÏÒÃÛskÎ;ñòì1ÔGþ'‡?Øm©|l›„8:‰Æ¥kFšƒ8Ë­©\˒ÒÑmâ@ºtt Gp t‰ÎŽ@ ú·ˆƒ©C/œq$ýjÙ¢ H_zú":)‹£K G·Z3º”Q<,eµ–¢c«—†¥G¡–ŽR(œ8ut{Jϖ©à •Ì(5rt«$3·¶ˆƒÔ‘h mŽö«u«šèÌ­z·ÅˆÆÚïˆ/3cGtp,â Ï!\ÆiŌ#\B﫵ôðîèë4=1dì•ù—ä_bп×ñߎ•Œì‹fÆ':ÿd<ý7c83> ÿƒzFþ?äiä_ÜfÖþÿçÔóÉGf|’LàŒ™õZ]Oí#®2󝜣ŸÝfÆÜôŸ/Ì,œeŽŽfæçƒ$“rç?ýyiF?UÏh,iýŒZÏ}zûµµÝœLß7њ#2òÎHËÞ«#}Cïû2­ïŽ~Òïε|⫵-ß±è=Š÷‰ŒÖ¹jùŸÆ‘oH0êè7?ŽþÕ GÆÓóͅÖOˆõ~ö눎Ž!8€%Gð@tætœï[µIF?ËÖûW'ùž"³s›Þ= -13p!8›zÚý7ÅÑo.2ßZ??×ûW°ŽŸ§Ò¢«#µÄ‘gµ~é÷;ÌÌøVOÏ_+"¬¿Ž|óA Ž}ŸJž¯‡Ó;Z+õē^\ë]#úÉ'ù$Ÿä“|’OòI>É'ù÷ ù$Ÿä“|’O’û&ÿùÏ¡ ôЋýs("^46nԁ6÷ñf§MÄÿÑŸÞõ¿o†¿œÜøôgêy÷`—;úøòËnœÙe÷^žŸÒBôõ (Ï4É*Omü‘–öîÀßLHêé9Ô³Œ—/<¢LÊðáÿ\òØ£ö«deal/R/0000755000175100001440000000000012101441103011361 5ustar hornikusersdeal/R/unique.R0000644000175100001440000000752512101441102013022 0ustar hornikusers## unique.R ## Author : Claus Dethlefsen ## Created On : Tue Jan 15 17:06:23 2002 ## Last Modified By: Claus Dethlefsen ## Last Modified On: Thu Jul 24 10:23:42 2003 ## Update Count : 68 ## Status : Unknown, Use with caution! ############################################################################### ## ## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### unique.networkfamily <- function(x,incomparables=FALSE,equi=FALSE,timetrace=FALSE,epsilon=1e-12,...) { ## returns a nwf with redundant networks removed ## nwf must be sorted ## equi=T: just one representative for each equivalence class (note ## that an equivalence class here is defined as all networks with ## the same score). ## Algorithm: ## create vector of scores ## create unique vector of scores ## for each unique score (=equivalence-class) ## find all networks with this score ## for each of these networks ## check if it is already in the list. If not, put it in. nwf <- x if (timetrace) {t1 <- proc.time();cat("[Unique ")} n <- length(nwf) tab <- rep(NA,n) for (i in 1:n) tab[i] <- nwf[[i]]$score utab <- unique(tab) if (equi) { ens <- abs(diff(tab)) < epsilon idx <- (1:(n-1))[!ens] if (!ens[n-1]) idx <- c(idx,n) utab <- tab[idx] nwl <- list() for (i in 1:length(utab)) nwl[[i]] <- nwf[[(1:n)[tab==utab[i]][1]]] } else { ## more work to do nwl <- list(nwf[[1]]) ntab <- c(nwf[[1]]$score) for (i in 2:length(nwf)) { try <- nwf[[i]] same <- nwl[(1:length(nwl))[ntab==c(try$score)]] jump <- FALSE if (length(same)>0) { for (j in 1:length(same)) if (nwequal( try, same[[j]])) { jump <- TRUE break } if (!jump) { nwl <- c(nwl,list(try)) ntab <- c(ntab,c(try$score)) } } else { nwl <- c(nwl,list(try)) ntab <- c(ntab,c(try$score)) } } } # else class(nwl) <- "networkfamily" if (timetrace) { t2 <- proc.time() cat((t2-t1)[1],"]\n") } nwl } nwequal <- function(nw1,nw2) { ## check if nw1 and nw2 has same DAG ## Output: (T/F) stopifnot(nw1$n==nw2$n) ## must have the same number of nodes. n <- nw1$n for (node in 1:n) { p1 <- nw1$nodes[[node]]$parents p2 <- nw2$nodes[[node]]$parents if ( length(p1) != length(p2) ) return(FALSE) N <- length(p1) if ( N>0 ) if (!all(sort(p1)==sort(p2))) return(FALSE) } return(TRUE) } elementin <- function(nw,nwl) { ## is the network nw in the list nwl? n <- length(nwl) tab <- rep(NA,n) for (i in 1:n) tab[i] <- nwl[[i]]$score same <- nwl[(1:length(nwl))[tab==c(nw$score)]] if (!length(same)>0) return(FALSE) for (i in 1:length(same)) if (nwequal(nw,same[[i]])) return(TRUE) return(FALSE) } deal/R/savenet.R0000644000175100001440000002772612101441102013166 0ustar hornikusers## savenet.R --- ## Author : Claus Dethlefsen ## Created On : Thu Sep 26 15:19:02 2002 ## Last Modified By: Claus Dethlefsen ## Last Modified On: Thu Sep 28 13:34:12 2006 ## Update Count : 97 ## Status : Unknown, Use with caution! ############################################################################### ## ## Copyright (C) 2002 Susanne Gammelgaard Bottcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### savenet <- function(nw,con=file("default.net")) { ## save network to .net file that can be read by eg. Hugin open(con,"w") cat("%Created by deal,",date(),"\n",file=con) # create empty file cat("%deal is Copyright (C) 2002-2006 Susanne Gammelgaard Bottcher, Claus Dethlefsen\n",file=con) cat(rep("%",60),"\n\n",sep="",file=con) ## ######################################## ## Global information ## ######################################## cat("net\n",file=con) cat("{\n",file=con) cat("\tnode_size = (40 40);\n",file=con) cat("}\n\n",file=con) ## ######################################## ## DEFINE NODES ## ######################################## for (i in 1:nw$n) { ## for each node nd <- nw$nodes[[i]] cat( nd$type, "node", nd$name, "\n", file=con) cat("{\n",file=con) if (nd$type=="discrete") { cat("\tstates = (", paste("\"",nd$levelnames,"\"",sep=""), ");\n", file=con) } cat("\tlabel = \"", nd$name,"\";\n",sep="",file=con) cat("\tposition = (", nd$position, ");\n",file=con) cat("}\n\n",file=con) } ## ######################################## ## DEFINE POTENTIALS ## ######################################## for (i in 1:nw$n) { nd <- nw$nodes[[i]] cat("\npotential (", nd$name, file=con) if (length(nd$parents)>0) { cat(" | ",file=con) ## for (j in nd$parents) ## cat(nw$nodes[[j]]$name," ",file=con) ## apparently, discrete parents must appear before cont. for (j in intersect(nd$parents,nw$discrete)) cat(nw$nodes[[j]]$name," ",file=con) for (j in intersect(nd$parents,nw$continuous)) cat(nw$nodes[[j]]$name," ",file=con) } cat(" )\n",file=con) cat("{\n",file=con) ## # parameters defining local distribution ## ################################################################## ## discrete nodes ## ################################################################## if (nd$type=="discrete") { cat("\tdata=(",file=con) ## the distribution of nd|parents in row-major layout if (length(nd$parents)>0) { cat("\n\t",file=con) if (FALSE) { cat("nd$prob\n") print(nd$prob) } dpar <- intersect(nd$parents,nw$discrete) ## Determine the discrete parents and their dimensions ## include (node$levels) as first component ## Dim <- c(nd$levels) Dim <- c() for (i in dpar) { Dim <- c(Dim, nw$nodes[[i]]$levels) } TD <- prod(Dim) ## dan alle teksterne i den rigtige rækkefolge lablist <- c() for (i in 1:TD) { cf <- findex( i, Dim, FALSE) ## label <- nd$levelnames[cf[1,1]] label <- "" ## for (j in 1:(ncol(cf)-1)) { for (j in 1:ncol(cf)) { ## label <- paste(label, nw$nodes[[dpar[j]]]$levelnames[cf[1,j+1]] label <- paste(label, nw$nodes[[dpar[j]]]$levelnames[cf[1,j]], sep=":") } lablist <- c(lablist,label) } ##we need to transform our column major mode ##to row major mode (used in .net files) cmajor <- array(1:TD,Dim) rmajor <- array(NA,Dim) for (i in 1:TD) { lD <- length(Dim) cf <- findex(i,Dim,config=FALSE) a <- c(1,cumprod(Dim[lD:1]))[lD:1] idx <- sum(a*(cf-1))+1 rmajor[cf] <- idx } ## rmajor <- array(1:TD,Dim[nDim]) ## rmajor <- aperm(rmajor,nDim) if (FALSE) { cat("cmajor:\n");print(cmajor) cat("rmajor:\n");print(rmajor) } ## write distribution for each config of disc. parents for (j in 1:TD) { ## transform from cmajor to rmajor if (length(dpar)>1) i <- cmajor[rmajor==j] else i <- j cf <- findex(i,Dim,config=FALSE) cfm <- cbind(1:nd$levels, matrix( rep(cf,nd$levels), ncol=length(cf), byrow=TRUE)) idx <- findex(cfm,c(nd$levels,Dim),config=TRUE) if (FALSE) { cat("cf=\n");print(cf) cat("cfm=\n");print(cfm) cat("Dim=\n");print(Dim) cat("c(nd$levels,Dim)=\n");print(c(nd$levels,Dim)) cat("idx=\n");print(idx) } cat(nd$prob[idx],"\t",file=con) cat("\t%",lablist[i],"\n\t",file=con) } } else { cat(nd$prob,file=con) } cat(");\n",file=con) } # discrete #################################################################### ## continuous nodes #################################################################### if (nd$type=="continuous") { cat("\tdata=(\n\t",file=con) ## skal skelne mellem kont. og disk. forældre ## hvis rene kont. forældre er prob en vektor if (length(nd$parents)>0) { # we have parents! if (length(intersect(nd$parents,nw$discrete))>0) { ## we have discrete parents dpar <- intersect(nd$parents,nw$discrete) ## Determine the discrete parents and their dimensions Dim <- c() for (i in dpar) { Dim <- c(Dim, nw$nodes[[i]]$levels) } TD <- prod(Dim) ## dan alle teksterne i den rigtige rækkefolge lablist <- c() for (i in 1:TD) { cf <- findex( i, Dim, FALSE) label <- "" for (j in 1:ncol(cf)) { label <- paste(label, nw$nodes[[dpar[j]]]$levelnames[cf[1,j]] ,sep=":") } lablist <- c(lablist,label) } ##we need to transform our column major mode ##to row major mode (used in .net files) if (length(dpar)>1) { nDim <- c(2,1) if (length(dpar)>2) # nDim <- c(nDim,3:length(Dim[-c(1,2)])) nDim <- c(nDim,3:length(Dim)) if (FALSE) { cat("Dim:",Dim,"\n") cat("nDim:",nDim,"\n") } ## ny strategi: udfyld rmajor paa en anden maade cmajor <- array(1:TD,Dim) rmajor <- array(NA,Dim) for (i in 1:TD) { lD <- length(Dim) cf <- findex(i,Dim,config=FALSE) a <- c(1,cumprod(Dim[lD:1]))[lD:1] idx <- sum(a*(cf-1))+1 rmajor[cf] <- idx } # rmajor <- array(1:TD,Dim[nDim]) # rmajor <- aperm(rmajor,nDim) if (FALSE) { cat("cmajor:\n");print(cmajor) cat("rmajor:\n");print(rmajor) } } ## write distribution for each config of disc. parents for (j in 1:TD) { ## transform from cmajor to rmajor if (length(dpar)>1) i <- cmajor[rmajor==j] else i <- j cat("\tnormal ( ",nd$prob[i,2],file=con) if (length(nd$prob[i,])>2) { #cont.parents for (j in 1:(length(nd$prob[i,])-2)) { if (nd$prob[i,j+2]>=0) cat("+",file=con) cat(nd$prob[i,j+2],"*", nw$nodes[[(intersect(nd$parents,nw$continuous))[j]]]$name,file=con) } } ## print remark in file with the config of disc.par. cat(", ",nd$prob[i,1],")","\t%",lablist[i],"\n",file=con) } } else { cat("normal ( ",nd$prob[2],file=con) for (j in 1:(length(nd$prob)-2)) { if (nd$prob[j+2]>=0) cat("+",file=con) cat(nd$prob[j+2],"*", nw$nodes[[(intersect(nd$parents,nw$continuous))[j]]]$name,file=con) } cat(", ",nd$prob[1],")\n",file=con) } } else { cat("normal ( ",nd$prob[2],", ",nd$prob[1],")\n",file=con) } cat("\t);\n",file=con) } cat("}\n",file=con) } # cat("Connection",filename,"created\n") close(con) invisible() } deal/R/rnetwork.R0000644000175100001440000002677512101441102013377 0ustar hornikusers## rnetwork.R ## Author : Claus Dethlefsen ## Created On : Tue Feb 26 11:22:30 2002 ## Last Modified By: Claus Dethlefsen ## Last Modified On: Wed Jan 07 08:36:02 2004 ## Update Count : 420 ## Status : Unknown, Use with caution! ############################################################################### ## ## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### rnetwork <- function(nw, n=24, file="") { ## Simulate a dataset and output to screen or 'file'. ## nw is a network consisting of: ## (slightly different from ordinary networks) ## nw$n: the number of nodes ## nw$ndiscrete: the number of discrete nodes ## nw$ncontinuous: the number of cont nodes ## nw$nodes: A list of nodes with parents defining the DAG mymultinomial <- function(n,p) { ## n: the number of cases to simulate ## p: a vector of probabilies for the categories mycoin <- runif(n) mycoin[mycoin==1] <- 0.99999 res <- rep(NA,n) prob <- c(0,cumsum(p)) for (i in 2:(length(p)+1) ) res[ prob[i-1] <= mycoin & mycoin < prob[i] ] <- i-1 res } res <- matrix(1, n, nw$n) res <- data.frame(res) colnames(res) <- names(nw$nodes) ## create factors for discrete variables if (length(nw$discrete)>0) { for (j in 1:length(nw$discrete)){ res[,nw$discrete[j]] <- factor(res[,nw$discrete[j]], levels=nw$nodes[[nw$discrete[j]]]$levelnames) } } ## #################################################################### ## simulate discrete nodes initsimlist <- c() nid <- 0 while ( length( setdiff(nw$discrete,initsimlist) )>0 ) { nid <- nid%%(nw$n)+1 if ( length(intersect(nid,initsimlist))>0) next node <- nw$nodes[[nid]] if (!node$type=="discrete" ) next if ( length( setdiff(node$parents,initsimlist) ) > 0 ) next if (!length(node$parents)>0) { ## discrete node without parents res[,node$idx] <- factor( node$levelnames[mymultinomial(n,node$simprob)], levels = node$levelnames) initsimlist <- c(initsimlist,nid) } else { ## discrete node with parents ptab <- table(res[,node$parents]) ## dimension of c(node,parents) Dim <- dim(node$simprob) pDim <- Dim[-1] # parent dimension for (j in 1:prod(pDim)) { cf <- findex(j,pDim,config=FALSE) idx <- 1:n for (k in 1:length(node$parents)) { pcf <- nw$nodes[[node$parents[k]]]$levelnames[cf[1,k]] idx <- idx[res[idx,node$parents[k]]==pcf] } nl <- node$levels np <- length(node$parents) up <- matrix( rep( cf, rep(nl,np) ), nl, np) icf <- cbind(1:node$levels,up) thissim <- mymultinomial(ptab[cf],node$simprob[icf]) res[idx,node$idx] <- node$levelnames[thissim] } ## for initsimlist <- c(initsimlist,nid) } } ## while ## #################################################################### ## simulate continuous nodes allnodes <- nw$continuous simlist <- initsimlist nid <- 0 while ( length( setdiff(allnodes,simlist) )>0 ) { nid <- nid%%(nw$n)+1 if ( length(intersect(nid,simlist))>0) next node <- nw$nodes[[nid]] parents <- node$parents if (nw$nd>0) dparents<- sort(intersect(parents,nw$discrete)) else dparents <- c() if (nw$nc>0) cparents<- sort(intersect(parents,nw$continuous)) if ( length( setdiff(parents,simlist) ) > 0 ) next if (!length(parents)>0) { ## no parents mu <- node$simprob[2] s2 <- node$simprob[1] res[,nid] <- rnorm(n,mu,sqrt(s2)) simlist <- c(simlist,nid) next } if (!length(dparents)>0) { ## no discrete parents s2 <- node$simprob[1] beta <- cbind(node$simprob[2:(length(cparents)+2)]) pres <- as.matrix(res[,cparents]) mu <- cbind(1,pres)%*%beta res[,nid] <- rnorm(n,mu,sqrt(s2)) simlist <- c(simlist,nid) next } ## if ## discrete and possibly cont. parents are present Dim <- c() for (i in dparents) Dim <- c(Dim,nw$nodes[[i]]$levels) for (j in 1:prod(Dim)) { cf <- findex(j,Dim,config=FALSE) idx <- 1:n for (k in 1:length(dparents)) { pcf <- nw$nodes[[dparents[k]]]$levelnames[cf[1,k]] idx <- idx[res[idx,dparents[k]]==pcf] } ## for k if (length(idx)>0) { if (!length(cparents)>0) { ## no cont. parents s2 <- node$simprob[j,1] mu <- node$simprob[j,2] } else { ## cont. parents beta <- cbind(node$simprob[j,2:(length(cparents)+2)]) ridx <- as.matrix(res[idx,cparents]) mu <- cbind(1,ridx)%*%beta } res[idx,nid] <- rnorm(length(idx),mu,sqrt(s2)) } ## if } ## for j simlist <- c(simlist,nid) next ## mixed parents break } ## while initsimlist <- simlist ## #################################################################### ## Last resort allnodes <- nw$continuous if ( length( setdiff(allnodes,initsimlist) )>0 ) { for (obs in 1:n) { ## simlist <- c() simlist <- initsimlist nid <- 0 while ( length( setdiff(allnodes,simlist) )>0 ) { nid <- nid%%(nw$n)+1 if ( length(intersect(nid,simlist))>0) next node <- nw$nodes[[nid]] parents <- node$parents if (nw$nd>0) dparents<- sort(intersect(parents,nw$discrete)) else dparents <- c() if (nw$nc>0) cparents<- sort(intersect(parents,nw$continuous)) if ( length( setdiff(parents,simlist) ) > 0 ) next if (!length(parents)>0) { if (node$type=="continuous") { res[obs,node$idx] <- rnorm(1,node$simprob[1,2],sqrt(node$simprob[1,1])) } else if (node$type=="discrete"){ res[obs,node$idx] <- node$levelnames[mymultinomial(1,node$simprob)] } } else { ###################################################################### ## at least one parent! if (node$type=="discrete") { Dim <- c() dnames <- list(node$levelnames) for (i in dparents) { Dim <- c(Dim,nw$nodes[[i]]$levels) dnames <- c(dnames,list(nw$nodes[[i]]$levelnames)) } Dim <- c(node$levels,Dim) pval <- c() for (j in parents) pval <- c(pval,res[obs,j]) idx <- cbind(1:node$levels) for (j in 1:length(pval)) idx <- cbind(idx,pval[j]) fidx <- findex(idx,Dim,config=TRUE) pvek <- node$simprob[fidx] pvek <- pvek/sum(pvek) names(pvek) <- node$levelnames res[obs,node$idx] <- node$levelnames[mymultinomial(1,pvek)] } else if (node$type=="continuous") { if (length(dparents)>0) { Dim <- c() dnames <- list(node$levelnames) for (i in dparents) { Dim <- c(Dim,nw$nodes[[i]]$levels) dnames <- c(dnames,list(nw$nodes[[i]]$levelnames)) } ## find out the configuration of disc parents pval <- c() for (j in dparents) pval <- c(pval,res[obs,j]) ## translate it to a row-number in simprob idx <- findex(rbind(pval),Dim,config=TRUE) } else { Dim <- c() idx <- 1 } ## get the values of the cont. variables cval <- c() for (j in cparents) cval <- c(cval,res[obs,j]) ## get the coefficients s2 <- node$simprob[idx,1] coef <- node$simprob[idx,2:ncol(node$simprob)] ## find the mean and variance. mn <- c(1,cval)%*%coef res[obs,node$idx] <- rnorm(1,mn,sqrt(s2)) } else stop("Node type illegal\n") } simlist <- c(simlist,nid) } ## while } ## for } ## if if (file!="") write.table(res,file=file,row.names=FALSE,col.names=TRUE) res } deal/R/readnet.R0000644000175100001440000000754112101441102013134 0ustar hornikusersreadnet <- function(con=file("default.net")) { ## read from .net file and create a network object. ## note: not all info from the .net file is used, so information ## may be lost (!) if overwriting the .net file with savenet(nw) ## The function is not foolproof if the .net files do not have the ## same structure as the deal generated .net files or the hugin ## net files we have seen after manipulating a Deal net file. # fn <- filename # zz <- file(fn,"r") open(con,"r") l <- readLines(con) lno <- length(l) lcount <- 0 nodes <- list() nodecount <- 1 nnames <- c() ## look for line with 'node' in it while (lcount <= lno) { lcount <- lcount + 1 nodeptr <- grep(" node ",l[lcount],value=TRUE) poteptr <- grep("potential ",l[lcount],value=TRUE) if (length(nodeptr)>0) { ## we have a node definition ss <- unlist(strsplit(l[lcount]," ")) ss <- ss[ss!=""] nd <- list() nd$idx <- nodecount nd$type <- ss[1] nd$name <- ss[3] nnames <- c(nnames,ss[3]) ## read position i <- 0 slut <- FALSE while (!slut) { i <- i+1 posstr <- grep("position",l[lcount+i],value=TRUE) if (length(posstr)>0) slut <- TRUE } ## extract coordinates from posstr c1 <- regexpr("[(]",posstr) x <- substr(posstr,c1+1,nchar(posstr)-2) y <- unlist(strsplit(x," ")) y <- y[y!=""] nd$position<- as.numeric(y) ## read levels if discrete if (nd$type=="discrete") { i <- 0 slut <- FALSE while (!slut) { i <- i+1 statestr <- grep("states",l[lcount+i],value=TRUE) if (length(statestr)>0) slut <- TRUE } ## extract states from statestr c1 <- regexpr("[(]",statestr) x <- substr(statestr,c1+1,nchar(statestr)-2) x <- gsub("\"","",x) y <- unlist(strsplit(x," ")) y <- y[y!=""] nd$levelnames <- y nd$levels <- length(nd$levelnames) } class(nd) <- "node" nodes[[nodecount]] <- nd nodecount <- nodecount + 1 } if (length(poteptr)>0) { ## we have a potential definition str <- poteptr c1 <- regexpr("[(]",str) c2 <- regexpr("[)]",str) x <- substr(str,c1+1,c2-1) c3 <- regexpr("[|]",x) if (c3==-1) { ## no conditional x <- gsub(" ","",x) nodenumber <- match(x,nnames) nodes[[nodenumber]]$parents <- c() } else { ## potentials lhs <- gsub(" ","",substr(x,1,c3-1)) nodenumber <- match(lhs,nnames) rhs <- substr(x,c3+1,nchar(x)) rhsy <- unlist(strsplit(rhs," ")) rhsy <- rhsy[rhsy!=""] parents <- match(rhsy,nnames) nodes[[nodenumber]]$parents <- parents } } } ## update network info nw <- list() names(nodes) <- nnames nw$nodes <- nodes nw$n <- length(nodes) ltype <- unlist(lapply(nw$nodes,function(x) x$type)) nw$discrete <- (1:nw$n)[ltype=="discrete"] nw$continuous <- (1:nw$n)[ltype=="continuous"] nw$nd <- length(nw$discrete) nw$nc <- length(nw$continuous) class(nw) <- "network" close(con) nw } deal/R/postdist.R0000644000175100001440000000531012101441102013353 0ustar hornikusers## postnw.R --- ## Author : Claus Dethlefsen ## Created On : Sat Sep 28 17:15:47 2002 ## Last Modified By: Claus Dethlefsen ## Last Modified On: Thu Jul 24 15:21:36 2003 ## Update Count : 17 ## Status : Unknown, Use with caution! ############################################################################### ## ## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### postdist <- function(nw) { ## calculate means of parameters and overwrite the prob attributes ## of the nodes nw$nodes <- lapply(nw$nodes,postdist.node,nw) nw } postdist.node <- function(nd,nw,vtype="mode") { ## calc. local prob from post.parameters (in cond.posterior) if (nd$type=="discrete") { if (length(nd$parents)>0) { a <- nd$condposterior[[1]]$alpha npa <- length(dim(a)) as<- apply(a,2:npa,sum) bs<- sweep(a,2:npa,as,"/") nd$prob <- bs } else { nd$prob <- nd$condposterior[[1]]$alpha/ sum(nd$condposterior[[1]]$alpha) } } if (nd$type=="continuous") { dpar <- intersect(nd$parents,nw$discrete) cpar <- intersect(nd$parents,nw$continuous) Dim <- c() for (i in dpar) { Dim <- c(Dim, nw$nodes[[i]]$levels) } TD <- prod(Dim) res <- matrix(NA,nrow=0,ncol=(2+length(cpar))) for (i in 1:TD) { cp <- nd$condposterior[[i]] mu <- cp$mu if (vtype=="mean") { ## mean s2 <- cp$phi/(cp$rho-2) } if (vtype=="mode") { ## mode s2 <- cp$phi/(cp$rho+2) } res <- rbind(res,c(s2,mu)) } nd$prob <- res } nd } deal/R/postc0.R0000644000175100001440000000527012101441102012717 0ustar hornikusers## postc0.R --- ## Author : Claus Dethlefsen ## Created On : Tue Mar 12 06:52:02 2002 ## Last Modified By: Claus Dethlefsen ## Last Modified On: Thu Jul 24 15:12:23 2003 ## Update Count : 100 ## Status : Unknown, Use with caution! ############################################################################### ## ## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### post0 <- function(mu,tau,rho,phi,y,timetrace=FALSE) { ## Posterior for continuous node with 0 parents if (timetrace) {t1 <- proc.time();cat("[post0 ")} mu.n <- (tau*mu+sum(y))/(tau+length(y)) tau.n <- tau + length(y) rho.n <- rho + length(y) phi.n <- phi + (y - mu.n)%*%y + (mu - mu.n)*tau*mu s <- as.numeric(phi)/rho*(diag(length(y)) + matrix(1/tau,length(y),length(y))) k <- lgamma( (rho + length(y))/2 ) - lgamma(rho/2)-0.5*log(det(rho*s*pi)) ind <- log( 1 + (mahalanobis(y,center=mu,cov=s,inverted=FALSE))/rho) loglik <- k - (rho+length(y))/2 * ind if (timetrace) { t2 <- proc.time() cat((t2-t1)[1],"]") } list(mu=mu.n,tau=tau.n,rho=rho.n,phi=phi.n,loglik=loglik) } postc0c <- function(mu,tau,rho,phi,y,timetrace=FALSE) { ## Posterior for continuous node with 0 parents if (timetrace) {t1 <- proc.time();cat("[postc0 ")} ## call to C res <- .C("postc0", mu =as.double(mu), tau=as.double(tau), rho=as.double(rho), phi=as.double(phi), loglik=as.double(0), as.double(y), as.integer(length(y)), PACKAGE="deal" ) if (timetrace) { t2 <- proc.time() cat((t2-t1)[1],"]") } list(mu=res$mu,tau=res$tau,rho=res$rho,phi=res$phi,loglik=res$loglik) } deal/R/postc.R0000644000175100001440000001144712101441102012642 0ustar hornikusers## postc.R --- ## Author : Claus Dethlefsen ## Created On : Tue Mar 12 06:52:02 2002 ## Last Modified By: Claus Dethlefsen ## Last Modified On: Fri Apr 20 09:25:29 2007 ## Update Count : 144 ## Status : Unknown, Use with caution! ############################################################################### ## ## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### postc <- function(mu,tau,rho,phi,y,z,timetrace=FALSE) { ## Posterior for continuous node with continuous parents ## written as a for-loop in R (slow) if (timetrace) {t1 <- proc.time();cat("[postc ")} loglik <- 0 for (i in 1:length(y)) { ## likelihood logscale <- log(phi) + log( 1 + t(z[i,])%*%solve(tau)%*%z[i,]) logk <- lgamma( (rho+1)/2 ) - lgamma(rho/2) - 0.5*(logscale + log(pi)) mscore <- logk - 0.5*(rho+1)*log(1 + ((y[i] - z[i,]%*%mu)^2)/exp(logscale)) loglik <- loglik + mscore ## update oldtau <- tau oldmu <- mu tau <- tau + z[i,]%*%t(z[i,]) mu <- solve(tau)%*%(oldtau%*%mu+z[i,]*y[i]) rho<- rho + 1 phi<- phi + (y[i]-t(z[i,])%*%mu)*y[i] + t(oldmu-mu)%*%oldtau%*%oldmu } if (timetrace) { t2 <- proc.time() cat((t2-t1)[1],"]") } list(mu=mu,tau=tau,rho=rho,phi=phi,loglik=loglik) } post <- function(mu,tau,rho,phi,y,z,timetrace=FALSE) { ## Posterior for continuous node with continuous parents ## written as matrix notation in R if (timetrace) {t1 <- proc.time();cat("[post ")} mu.n <- solve(tau+t(z)%*%z)%*%(tau%*%mu+t(z)%*%y) tau.n <- tau + t(z)%*%z rho.n <- rho + length(y) phi.n <- phi + t(y - z%*%mu.n)%*%y + t(mu - mu.n)%*%tau%*%mu loglik <- 0 s <- as.numeric(phi)/rho*(diag(nrow(z))+ z%*%solve(tau)%*%t(z)) k <- lgamma( (rho + length(y))/2 ) - lgamma(rho/2)-0.5*log(det(rho*s*pi)) ind <- log( 1 + (mahalanobis(y,center=z%*%mu,cov=s,inverted=FALSE))/rho) loglik <- as.numeric(k) - (rho+length(y))/2 * ind if (timetrace) { t2 <- proc.time() cat((t2-t1)[1],"]") } list(mu=mu.n,tau=tau.n,rho=rho.n,phi=phi.n,loglik=loglik) } ## postM <- function(mu,tau,rho,phi,y,z,timetrace=FALSE) { ## ## Posterior for continuous node with continuous parents ## ## written as Matrix notation in R (needs Matrix) ## if (timetrace) {t1 <- proc.time();cat("[postM ")} ## z <- as.Matrix(z) ## mu.n <- solve(as.Matrix(tau+t(z)%*%z))%*%(tau%*%mu+t(z)%*%y) ## tau.n <- tau + t(z)%*%z ## rho.n <- rho + length(y) ## phi.n <- phi + t(y - z%*%mu.n)%*%y + t(mu - mu.n)%*%tau%*%mu ## loglik <- 0 ## s <- as.numeric(phi)/rho*(diag(nrow(z))+ z%*%solve(tau)%*%t(z)) ## k <- lgamma( (rho + length(y))/2 ) - lgamma(rho/2)-0.5*log(det(rho*s*pi)) ## ind <- log( 1 + (mahalanobis(y,center=z%*%mu,cov=s,inverted=FALSE))/rho) ## loglik <- as.numeric(k) - (rho+length(y))/2 * ind ## if (timetrace) { ## t2 <- proc.time() ## cat((t2-t1)[1],"]") ## } ## list(mu=mu.n,tau=tau.n,rho=rho.n,phi=phi.n,loglik=loglik) ## } postcc <- function(mu,tau,rho,phi,y,z,timetrace=FALSE) { ## Posterior for continuous node with x parents ## written as for-loop in C (fast) if (timetrace) {t1 <- proc.time();cat("[postcc ")} ## call to C res <- .C("postc", mu =as.double(c(mu)), tau=as.double(t(tau)), rho=as.double(rho), phi=as.double(phi), loglik=as.double(0), as.double(y), as.double(t(z)), as.integer(length(y)), as.integer(ncol(z)), PACKAGE="deal" ) if (timetrace) { t2 <- proc.time() cat((t2-t1)[1],"]") } list(mu=res$mu,tau=matrix(res$tau,ncol(z),ncol(z)),rho=res$rho,phi=res$phi,loglik=res$loglik) } deal/R/perturb.R0000644000175100001440000001453412101441102013175 0ustar hornikusers## perturb.ssc --- ## Author : Claus Dethlefsen ## Created On : Sun Jan 13 10:16:01 2002 ## Last Modified By: Claus Dethlefsen ## Last Modified On: Mon Jan 12 14:51:19 2004 ## Update Count : 105 ## Status : Unknown, Use with caution! ############################################################################### ## ## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### perturb <- function(nw,data,prior,degree=size(nw),trylist=vector("list",size(nw)),nocalc=FALSE,timetrace=TRUE) { ## change nw by randomly adding, deleting or turning arrows. ## In 'degree' steps, one of the three actions is taken. Note that ## adding, deleting or turning may not be possible due to an empty ## graph or a complete graph, so that the returned network is ## identical to the input network. (is this wanted?) If nw is ## {empty,complete}, ## the returned network is slightly likely to be {empty,complete} ## nocalc=T: do not learn network (data+prior are not used) if (timetrace) {t1 <- proc.time();cat("[Perturb ")} for (i in 1:degree) { choice <- runif(1) if (choice <= 1/3) nw <- addrandomarrow(nw,data,prior,trylist,nocalc,timetrace=FALSE) else if (choice <= 2/3) nw <- turnrandomarrow(nw,data,prior,trylist,nocalc,timetrace=FALSE) else if (choice <= 1) nw <- deleterandomarrow(nw,data,prior,trylist,nocalc,timetrace=FALSE) trylist <- nw$trylist nw <- nw$nw } ## sort the parents of each node for (i in 1:nw$n) { if (length(nw$nodes[[i]]$parents)>0) nw$nodes[[i]]$parents <- sort(nw$nodes[[i]]$parents) } if (timetrace) { t2 <- proc.time() cat((t2-t1)[1],"]\n") } list(nw=nw,trylist=trylist) } addrandomarrow <- function(nw,data,prior,trylist=vector("list",size(nw)),nocalc=FALSE,timetrace=FALSE) { ## add an arrow at random. Continue until one arrow is added or the ## graph is complete. if (timetrace) {t1 <- proc.time();cat("[addrandomarrow ")} n <- nw$n ## all possible combinations possible <- findex(1:(n^2), c(n,n),config=FALSE) ## delete arrows from a node to itself possible <- possible[diff(t(possible))!=0,] m <- nrow(possible) ## perturb order <- sample(1:m,m) for (r in order) { from <- possible[r,1] to <- possible[r,2] newnet <- insert(nw, from,to,data,prior,trylist=trylist,nocalc=nocalc) trylist <- newnet$trylist newnet <- newnet$nw if (length(newnet)>0) { if (!cycletest(newnet)) { if (timetrace) { t2 <- proc.time() cat((t2-t1)[1],"] ") } return(list(nw=newnet,trylist=trylist)) } else {;#cat("Oh, no - you created a cycle. Try again\n") } } } ## cat("not possible to add arrow\n") if (timetrace) { t2 <- proc.time() cat((t2-t1)[1],"] ") } list(nw=nw,trylist=trylist) } turnrandomarrow <- function(nw,data,prior,trylist=vector("list",size(nw)),nocalc=FALSE,timetrace=FALSE) { ## continue until an arrow is turned or it is not possible if (timetrace) {t1 <- proc.time();cat("[turnrandomarrow ")} ## make a list of arrows parentlist <- c() for (i in 1:nw$n) { theseparents <- nw$nodes[[i]]$parents if (length(theseparents)>0) parentlist <- rbind(parentlist, cbind(i,theseparents)) } if (length(parentlist)==0) { if (timetrace) { t2 <- proc.time() cat((t2-t1)[1],"]\n") } return(list(nw=nw,trylist=trylist)) } ## try to turn them one by one until it succeeds. m <- nrow(parentlist) order <- sample(1:m,m) for (r in order) { to <- parentlist[r,1] from <- parentlist[r,2] newnet <- nw newnet$nodes[[to]]$parents <- setdiff(newnet$nodes[[to]]$parents,from) if (!nocalc) { newnet <- learn(newnet,data,prior,to,trylist=trylist) trylist <- newnet$trylist newnet <- newnet$nw } newnet <- insert(newnet, to, from,data,prior,trylist=trylist,nocalc=nocalc) trylist <- newnet$trylist newnet <- newnet$nw if (length(newnet)>0) if (!cycletest(newnet)) { if (timetrace) { t2 <- proc.time() cat((t2-t1)[1],"] ") } return(list(nw=newnet,trylist=trylist)) } else {;# cat("Oh, no - you created a cycle. Try again\n") } } ## cat("not possible to turn any arrows\n") if (timetrace) { t2 <- proc.time() cat((t2-t1)[1],"] ") } list(nw=nw,trylist=trylist) } deleterandomarrow <- function(nw,data,prior,trylist=vector("list",size(nw)),nocalc=FALSE,timetrace=timetrace) { ## delete an arrow at random. Return nw, if the graph is empty. if (timetrace) {t1 <- proc.time();cat("[deleterandomarrow ")} parentlist <- c() for (i in 1:nw$n) { theseparents <- nw$nodes[[i]]$parents if (length(theseparents)>0) parentlist <- rbind(parentlist, cbind(i,theseparents)) } if (length(parentlist)==0) { if (timetrace) { t2 <- proc.time() cat((t2-t1)[1],"] ") } return(list(nw=nw,trylist=trylist)) } ## choose a parent at random todie <- sample(1:nrow(parentlist),1) ## and delete it i <- parentlist[todie,1] p <- parentlist[todie,2] nw$nodes[[i]]$parents <- setdiff(nw$nodes[[i]]$parents,p) if (!nocalc) { nw <- learn(nw,data,prior,i,trylist=trylist) trylist <- nw$trylist nw <- nw$nw } if (timetrace) { t2 <- proc.time() cat((t2-t1)[1],"] ") } list(nw=nw,trylist=trylist) } deal/R/numbermixed.R0000644000175100001440000000344412101441102014027 0ustar hornikusers## numbermixed.R ## Author : Claus Dethlefsen ## Created On : Sat Mar 02 11:37:20 2002 ## Last Modified By: Claus Dethlefsen ## Last Modified On: Thu Jul 24 09:56:07 2003 ## Update Count : 24 ## Status : Unknown, Use with caution! ############################################################################### ## ## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### numbermixed <- function(nd,nc) { ## number of mixed networks with nd discrete and nc continuous nodes ## (see Bøttcher (2002)) robinson <- function(n) { ## The Robinson (1977) recursive formula for the number of possible ## DAGs that contain n nodes if (n<=1) return(1) else { res <- 0 for (i in 1:n) { res <- res + (-1)^(i+1) * choose(n,i) * 2^(i*(n-i)) * Recall(n-i) } } res } robinson(nd)*robinson(nc)*2^(nd*nc) } deal/R/node.R0000644000175100001440000003050312101441102012431 0ustar hornikusers## node.R ## Author : Claus Dethlefsen ## Created On : Fri Nov 02 21:18:50 2001 ## Last Modified By: Claus Dethlefsen ## Last Modified On: Wed Jul 28 09:39:55 2004 ## Update Count : 410 ## Status : OK ############################################################################### ## ## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### nodes <- function(nw) nw$nodes "nodes<-" <- function(nw,value) {nw$nodes<-value;nw} localprob <- function(nw) lapply(nodes(nw),function(node) node$prob) "localprob<-" <- function(nw,name,value) { names(value) <- names(nodes(nw)[[name]]$prob) nodes(nw)[[name]]$prob <- value nw } localprior <- function(node) node$condprior localposterior <- function(node) node$condposterior node <- function(idx,parents,type="discrete",name=paste(idx), levels=2,levelnames=paste(1:levels), position=c(0,0)) { ## creator for class 'node' ## idx: The unique index of the node ## name: The plotted name ## parents: Vector with indices of parents ## type: "discrete" or "continuous" ## levels: If discrete, the number of levels ## levelnames:If discrete, the printed names of the levels nd <- list() nd$idx <- idx nd$parents <- parents nd$type <- type nd$name <- name nd$position<- position if (type=="discrete") { nd$levels <- levels nd$levelnames <- levelnames } class(nd) <- "node" nd } print.node <- function(x,filename=NA,condposterior=TRUE,condprior=TRUE,...) { nd <- x str <- paste(nd$idx,nd$name,nd$type,sep="\t") str <- paste(str,"(",nd$levels,")",sep="") for (i in 1:length(nd$parents)) { if (length(nd$parents)>0) str <- paste(str,nd$parents[i],sep="\t") } if (is.na(filename)) cat(str,"\n") else cat(str,"\n",file=filename,append=TRUE) if (condprior) { printline() cat("Conditional Prior:",nd$name) if (length(nd$parents)>0) { cat("| ") for (j in 1:length(nd$parents)) cat(nd$parents[j]," ") } cat("\n") print(nd$condprior) } if (condposterior) { printline() cat("Conditional Posterior:",nd$name) if (length(nd$parents)>0) { cat("| ") for (j in 1:length(nd$parents)) cat(nd$parents[j]," ") } cat("\n") print(nd$condposterior) } invisible(nd) } plot.node <- function(x,cexscale=10,notext=FALSE,...) { if (x$type=="discrete") {tt <- 19;col <- "white"} else {tt <- 21;col <- "black"} points(x$position[1],x$position[2],cex=cexscale,pch=tt,...) if (!notext) text(x$position[1],x$position[2],x$name,col=col,...) } prob.node <- function(x,df,nw,...) { data <- df node <- x # for compatibility reasons. ## node: current node ## nw: The network - we need the parents of the node ## data: for continuous nodes, we need to estimate mu and sigma2 ## from data. For discrete nodes we need to count the number of ## cases for each state. ## ## Returns: a node with the prob-attribute set to ## for discrete: an array of dimension equal to the levels ## of the discrete parents and value: ## if equalcases=T 1/xx, where xx is ## the product of the levels. nodelist <- nw$nodes if (node$type=="discrete") { vek <- rep(NA,length(node$parents)+1) vek[1] <- node$levels dnames <- list(node$levelnames) if (length(node$parents)>0) { for (i in 1:length(node$parents)) { vek[i+1] <- nodelist[[node$parents[i]]]$levels dnames <- c(dnames, list(nodelist[[node$parents[i]]]$levelnames)) } } node$prob <- array(1/prod(vek),dim=vek) dimnames(node$prob) <- dnames if (length(node$parents)>0) node$prob <- prop.table(node$prob,2:(length(node$parents)+1)) } ## type=="discrete" if (node$type=="continuous") { ## for each product level of discrete parents, calculate ## mean and variance from the data. if (length(node$parents)>0) { parents <- sort(node$parents) if (nw$nd>0) dparents<- sort(intersect(parents,nw$discrete)) else dparents <- c() if (nw$nc>0) cparents<- sort(intersect(parents,nw$continuous)) if (length(cparents)>0) { if (length(dparents)>0) { ## at least one discrete and one continuous parent ## cat("The true mixed case\n") ## find configurations of discrete variables ## for each configuration ## reduce data ## do a regression on the cont.parents Dim <- c() dnames <- list() for (i in dparents) { Dim <- c(Dim,nw$nodes[[i]]$levels) dnames <- c(dnames,list(nw$nodes[[i]]$levelnames)) } TD <- prod(Dim) ## create labels lvek <- c() for (i in 1:TD) { cf <- findex( i, Dim, FALSE) label <- "" for (j in 1:ncol(cf)) { label <- paste(label, nw$nodes[[dparents[j]]]$levelnames[cf[1,j]] ,sep=":") } lvek <- c(lvek,label) } M <- matrix(NA,TD,2+length(cparents)) rownames(M) <- lvek colnames(M) <- c("s2",paste("Intercept",node$name,sep=":"), names(data)[cparents]) for (i in 1:TD) { config <- findex(i,Dim,config=FALSE) obs <- data[,c(dparents,cparents,node$idx)] for (k in 1:ncol(config)) { j <- config[1,k] ## reduce data lev <- nw$nodes[[dparents[k]]]$levelnames[j] obs <- obs[obs[,k]==lev,] } X <- obs[,(length(dparents)+1):(ncol(obs)-1)] y <- obs[,ncol(obs)] lsobj <- lsfit(X,y) beta <- coef(lsobj) s2 <- sum(resid(lsobj)^2)/nrow(data) M[i,] <- c(s2,beta) } node$prob <- M } else { ## only continuous parents X <- data[,cparents] y <- data[,node$idx] lsobj <- lsfit(X,y) beta <- coef(lsobj) s2 <- sum(resid(lsobj)^2)/nrow(data) node$prob <- c(s2,beta) names(node$prob) <- c("s2", paste("Intercept",node$name,sep=":") ,names(data)[cparents]) } } else { ## only discrete parents Dim <- c() dnames <- list() for (i in dparents) { Dim <- c(Dim,nw$nodes[[i]]$levels) dnames <- c(dnames,list(nw$nodes[[i]]$levelnames)) } TD <- prod(Dim) ## create labels lvek <- c() for (i in 1:TD) { cf <- findex( i, Dim, FALSE) label <- "" for (j in 1:ncol(cf)) { label <- paste(label, nw$nodes[[dparents[j]]]$levelnames[cf[1,j]] ,sep=":") } lvek <- c(lvek,label) } M <- matrix(NA,TD,2) rownames(M) <- lvek colnames(M) <- c("s2",paste("Intercept",node$name,sep=":")) for (i in 1:TD) { ## Find configuration of discrete parents ## Find the data that fits ## mean,var of these variables ## if no data: mean=0, var=100 config <- findex(i,Dim,config=FALSE) obs <- data[,c(dparents,node$idx)] for (k in 1:ncol(config)) { j <- config[1,k] ## reduce data lev <- nw$nodes[[dparents[k]]]$levelnames[j] obs <- obs[obs[,k]==lev,] } if (nrow(obs)>1) { n <- nrow(obs) M[i,] <- c(var(obs[,ncol(obs)])*(n-1)/n, mean(obs[,ncol(obs)])) } else { M[i,] <- c(100,0) if (nrow(obs)==1) M[i,2] <- obs[1,ncol(obs)] } ## else } ## for node$prob <- M } ## else } ## if parents else { ## no parents n <- dim(data)[1] node$prob <- c(var(data[,node$idx])*(n-1)/n,mean(data[,node$idx])) names(node$prob) <- c("s2",paste("Intercept",node$name,sep=":")) } } ## type=="continuous" node } ## function: prob.node cond.node <- function(node,nw,nw.prior=jointprior(nw)) { ## make conditional prior for this node and attach it thismaster <- localmaster(sort(c(node$idx,node$parents)), nw,nw.prior) if (length(node$parents)>0) { ## parents are present thiscond <- conditional(node$idx,thismaster,nw) if (node$type=="continuous") { contparents <- intersect(node$parents,nw$continuous) if (length(contparents)<1) { ## no cont. parents for (k in 1:length(thiscond)) { thiscond[[k]]$tau <- thismaster$nu[k] thiscond[[k]]$mu <- thismaster$mu[k] thiscond[[k]]$phi <- thismaster$phi[[k]] thiscond[[k]]$rho <- thismaster$rho[k] } } } } else { ## no parents, so thiscond is just the master thiscond <- list(thismaster) thiscond[[1]]$tau <- thismaster$nu } ## node$master <- thismaster ## only used for debugging node$condprior <- thiscond node } deal/R/networkfamily.R0000644000175100001440000001261512101441102014403 0ustar hornikusers## networkfamily.R ## Author : Claus Dethlefsen ## Created On : Tue Oct 30 16:43:05 2001 ## Last Modified By: Claus Dethlefsen ## Last Modified On: Wed Jul 28 09:39:43 2004 ## Update Count : 429 ## Status : Unknown, Use with caution! ############################################################################### ## ## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### networkfamily <- function(data,nw=network(data),prior=jointprior(nw), trylist=vector("list",size(nw)),timetrace=TRUE) { ## Creator class for networkfamily ## ## Generates all possible networks with the restriction that ## discrete nodes cannot have continuous parents. (see insert) ## Uses: numbermixed, addarrows, learn.network, cycletest ## and attributes of nw: nd,nc ## Value: ## networklist: A list of network-objects ## trylist: an updated trylist if (timetrace) {t1 <- proc.time();cat("[networkfamily ")} nw <- learn(nw,data,prior,trylist=trylist) trylist <- nw$trylist nw <- nw$nw ndiscrete <- nw$nd ncontinuous<- nw$nc cat("Creating all (", numbermixed(ndiscrete,ncontinuous), " minus restrictions) networks with ",ndiscrete," discrete and ", ncontinuous," continuous nodes\n",sep="") nwl <- list() # network list n <- ndiscrete + ncontinuous nwl <- list(nw) # current network list for (node in 2:n) { for (idx in 1:length(nwl)) { nws <- addarrows(nwl[[idx]],node,data,prior,trylist=trylist) trylist <- nws$trylist nwl <- c(nwl,nws$nw) } } cat("Created",length(nwl),"networks, ") if (ndiscrete>2|ncontinuous>2) { cat("removing cycles...\n") nwlres <- nwl[!unlist(lapply(nwl,cycletest))] cat(length(nwl)-length(nwlres),"cycles removed, ending up with",length(nwlres),"networks\n") } else nwlres <- nwl class(nwlres) <- "networkfamily" if (timetrace) { t2 <- proc.time() cat((t2-t1)[1],"]\n") } list(nw=nwlres,trylist=trylist) } plot.networkfamily <- function(x, layout=rep(min(1+floor(sqrt(length(x))),5),2), cexscale=5,arrowlength=0.1, sscale=7,...) { nwf <- x par(mfrow=layout) for (i in 1:length(nwf)) { par(mar=c(0,0,0,0)) plot(nwf[[i]],cexscale=cexscale,arrowlength=arrowlength,sscale=sscale,showban=FALSE,...) } par(mfrow=c(1,1)) } nwfsort <- function(nwf) { ## sort according to network score, and add relative scores n <- length(nwf) ## first, create a vector with the indices and scores tab <- rep(NA,n) for (i in 1:n) tab[i] <- nwf[[i]]$score ## then find the sort list of indices sl <- sort.list(-tab) relscore <- exp(tab - tab[sl[1]]) ## create the sorted family nwf <- nwf[sl] for (i in 1:n) nwf[[i]]$relscore <- relscore[sl[i]] class(nwf) <- "networkfamily" nwf } print.networkfamily <- function(x,...) { nwf <- nwfsort(x) ## ensure they are sorted g <- function(x) x$name nw <- nwf[[1]] cat("Discrete: ") if (nw$nd>0) { nn <- nw$discrete[1] cat(nw$nodes[[nn]]$name,"(",nw$nodes[[nn]]$levels,")",sep="") if (nw$nd>1) { for (i in nw$discrete[-1]) cat(",",nw$nodes[[i]]$name,"(",nw$nodes[[i]]$levels,")",sep="") } cat("\n") } else cat("\n") cat("Continuous:") if (nw$nc>0) { nn <- nw$continuous[1] cat(nw$nodes[[nn]]$name,sep="") if (nw$nc>1) { for (i in nw$continuous[-1]) cat(",",nw$nodes[[i]]$name,sep="") } cat("\n") } else cat("\n") cat(" log(Score)\t|Relscore\t|Network\n") printline() for (i in 1:length(nwf)) { nw <- nwf[[i]] cat(i,". ",nw$score,"\t",nw$relscore,sep="") if (i==1) cat("\t") cat("\t",sep="") for (j in 1:nw$n) { nd <- nw$nodes[[j]] cat("[",nd$name,sep="") if (length(nd$parents)>0) { cat("|", unlist(lapply(nw$nodes[nd$parents],g)), sep="") } cat("]") } cat("\n") } ## for invisible(nwf) } deal/R/network.R0000644000175100001440000001503512101441102013200 0ustar hornikusers## network.R ## Author : Claus Dethlefsen ## Created On : Fri Nov 02 21:20:16 2001 ## Last Modified By: Claus Dethlefsen ## Last Modified On: Fri Jan 09 10:00:47 2004 ## Update Count : 319 ## Status : Unknown, Use with caution! ############################################################################### ## ## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### network <- function(df,specifygraph=FALSE,inspectprob=FALSE, doprob=TRUE, yr=c(0,350),xr=yr) { ## creator for class 'network' ## df is a dataframe with one column per variable and one row per ## observation. Discrete variables are factors. We assume complete ## data, that is no NA's and at least one observation for each ## configuration of the factors. ## ## We create a 'trivial' network, which is a network without any arrows. if (length(dim(df))<1) stop("Can't handle networks with one node, sorry\n") nw <- list() nw$n <- ncol(df) ## df must have at least 2 columns... nw$discrete <- c() nw$continuous <- c() nw$nodes <- list() unit <- 2*pi/nw$n xc <- mean(xr) yc <- mean(yr) for (i in 1:nw$n) { pos <- c(cos( unit*i+pi/4),sin(unit*i+pi/4))*xc*.8 + c(xc,yc) ## create one node per column if (is.factor(df[,i])) { ## the node is discrete nw$nodes[[i]] <- node(i,c(),"discrete", names(df)[i], length(levels(df[,i])), levels(df[,i]), position=pos ) nw$discrete <- c(nw$discrete,i) } else { ## the node is continuous nw$nodes[[i]] <- node(i,c(),"continuous", names(df)[i], position=pos ) nw$continuous <- c(nw$continuous,i) } } nw$nd <- length(nw$discrete) nw$nc <- length(nw$continuous) stopifnot(nw$nd+nw$nc==nw$n) # invariant names(nw$nodes) <- names(df) class(nw) <- "network" if (specifygraph) { nw <- drawnetwork(nw,nocalc=TRUE)$nw } if (doprob) nw <- prob(x=nw,df=df) if (inspectprob) nw <- inspectprob(nw) nw } print.network <- function(x,filename=NA,condposterior=FALSE, condprior=FALSE,...) { nw <- x str <- paste("## ",nw$n,"(",nw$nd,"discrete+",nw$nc,") nodes;score=", nw$score,";relscore=",nw$relscore,"\n") if (is.na(filename)) cat(str) else cat(str,file=filename) for (i in 1:nw$n) print(nw$nodes[[i]],filename=filename,condposterior,condprior) invisible(nw) } plot.network <- function(x,arrowlength=.25, notext=FALSE,sscale=7,showban=TRUE, yr=c(0,350),xr=yr ,unitscale=20,cexscale=8,...) { nw <- x plot(0,0,xlim=xr, ylim=yr,type="n", axes=FALSE,xlab="",ylab="",...) unit <- 2*pi/nw$n xc <- mean(xr) # center coordinates yc <- mean(yr) # ## show nodes for (i in 1:nw$n) plot(nw$nodes[[i]], cexscale=cexscale,notext=notext,...) ## show score and relscore if (length(nw$score)>0 && !notext) { string <- paste("Score:",format(nw$score,2)) if (length(nw$relscore)>0) string <- paste(string,"\n","Relscore:",format(nw$relscore,2)) text(xc,0.97*yr[2],string) } ## show banlist if (showban) { if (!is.null(nw$banlist)) if (nrow(nw$banlist)>0) { bl <- nw$banlist for (i in 1:nrow(bl)) { from <- bl[i,2] to <- bl[i,1] x <- nw$nodes[[from]]$position y <- nw$nodes[[to]]$position u <- (x - y) / sqrt(sum( (x-y)^2 )) x <- x - u*unitscale y <- y + u*unitscale arrows( y[1],y[2],x[1],x[2],length=arrowlength,col="red",lty=2) } ## for } ## if (nrow...) } ## if (showban) ##< show arrows for (i in 1:nw$n) { ni <- nw$nodes[[i]] # node i if (length(ni$parents)>0) { for (j in 1:length(ni$parents)) { x <- ni$position # coords of ni pj <- ni$parents[j] # parent j (index) y <- nw$nodes[[pj]]$position # coords of pj u <- (x - y) / sqrt(sum( (x-y)^2 )) # unit vector from y to x x <- x - u*unitscale y <- y + u*unitscale arrows( y[1],y[2],x[1],x[2],length=arrowlength,...) } } } } score <- function(x,...) { UseMethod("score") } score.network <- function(x,...) { return(x$score) } score.node <- function(x,...) { return(x$loglik) } prob <- function(x,df,...) { UseMethod("prob") } prob.network <- function(x,df,...) { ## calculate initial probability x$nodes <- lapply(x$nodes,prob,df,x) x } banlist <- function(x) { x$banlist } "banlist<-" <- function(x,value) {x$banlist <- value;x} getnetwork <- function(x) x$nw gettrylist <- function(x) x$trylist gettable <- function(x) x$table size <- function(x) x$n deal/R/master.R0000644000175100001440000001125312101441102013000 0ustar hornikusers## master.R ## Author : Claus Dethlefsen ## Created On : Thu Nov 29 21:28:29 2001 ## Last Modified By: Claus Dethlefsen ## Last Modified On: Wed Jul 23 19:22:41 2003 ## Update Count : 299 ## Status : Unknown, Use with caution! ############################################################################### ## ## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### localmaster <- function(family,nw,prior=jointprior(nw)) { ## family: indices of a subset of nodes in the network 'nw' ## jointprior: jointprior(nw,N) ## ## Returns: the joint local master prior for the family listsum <- function(liste,idx=1:nrow(liste[[1]])) { ## sum elements of list containing a matrix as each element ## narrow down to liste[[i]][idx,idx] (always made to be a matrix) res <- matrix(0, nrow(as.matrix(liste[[1]][idx,idx])), ncol(as.matrix(liste[[1]][idx,idx]))) for (i in 1:length(liste)) res <- res + as.matrix(liste[[i]][idx,idx]) res } ## determine indices of discrete and cont. nodes didx <- match(family,nw$discrete) didx <- didx[!is.na(didx)] cidx <- match(family,nw$continuous) cidx <- cidx[!is.na(cidx)] ## initialize alpha <- NA nu <- NA rho <- NA mu <- NA phi <- NA if (!length(cidx)>=1) { ## no cont. nodes alpha <- apply(prior$jointalpha,didx,sum) } else if(!length(didx)>=1) { ## no disc. nodes nu <- sum(prior$jointnu) rho<- sum(prior$jointrho) M <- as.matrix(prior$jointmu[,cidx]*c(prior$jointnu)) if (nrow(prior$jointmu)==1) dim(M) <- c(1,length(prior$jointmu[,cidx])) mu <- apply( M ,2,sum )/nu ss <- matrix(0,length(cidx),length(cidx)) for (i in 1:nrow(prior$jointmu)) { thismu <- as.matrix(prior$jointmu[i,cidx]) mumean <- as.matrix(mu) ss <- ss+prior$jointnu[i]*(thismu-mumean)%*%t(thismu-mumean) } phi<- listsum(prior$jointphi,cidx)+ss } else { ## mixed nu <- apply(prior$jointnu ,didx, sum) rho <- apply(prior$jointrho ,didx, sum) nconfig <- length(nu) # number of configs. mu <- matrix(0,nconfig,length(cidx)) phi <- list() for (i in 1:nconfig) phi[[i]] <- matrix(0,length(cidx),length(cidx)) ## find dimension from levels of discrete nodes D <- c() for (i in 1:length(didx)) { D <- c(D,nw$nodes[[nw$discrete[didx[i]]]]$levels) } jmu <- prior$jointmu for (i in 1:nrow(jmu)) { ## the corresp. configuration of the disc. variables in the ## joint distribution idx <- findex(i,dim(prior$jointalpha),config=FALSE) y <- findex(matrix(idx[didx],1),D,config=TRUE) mu[y,] <- mu[y,] + jmu[i,cidx]*prior$jointnu[i] phi[[y]][,] <- phi[[y]][,] + prior$jointphi[[i]][cidx,cidx] } for (i in 1:nrow(mu)) mu[i,] <- mu[i,]/nu[i] ## adjust phi with sum(nu_j(mu_j-mean(mu))(mu_j-mean(mu))^t) for (i in 1:nrow(jmu)) { idx <- findex(i,dim(prior$jointalpha),config=FALSE) y <- findex(matrix(idx[didx],1),D,config=TRUE) phi[[y]] <- phi[[y]] + prior$jointnu[i]*(jmu[i,cidx]-mu[y,])%*%t(jmu[i,cidx]-mu[y,]) rownames(phi[[y]]) <- colnames(phi[[y]]) } colnames(mu) <- colnames(phi[[1]]) } list(alpha=alpha, nu=nu, rho=rho, mu=mu, phi=phi) } deal/R/maketrylist.R0000644000175100001440000000313612101441102014056 0ustar hornikusers## maketrylist.R ## Author : Claus Dethlefsen ## Created On : Fri Jan 11 10:54:00 2002 ## Last Modified By: Claus Dethlefsen ## Last Modified On: Wed Jul 23 13:35:14 2003 ## Update Count : 196 ## Status : Unknown, Use with caution! ############################################################################### ## ## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### maketrylist <- function(initnw,data,prior=jointprior(network(data)), timetrace=FALSE) { if (timetrace) {t1 <- proc.time();cat("[Maketrylist ")} tryl <- networkfamily(data,initnw,prior,timetrace=timetrace)$trylist if (timetrace) { t2 <- proc.time() cat((t2-t1)[1],"]\n") } tryl } deal/R/makesimprob.R0000644000175100001440000001107212101441102014015 0ustar hornikusers## makesimprob.R ## Author : Claus Dethlefsen ## Created On : Tue Feb 26 13:25:44 2002 ## Last Modified By: Claus Dethlefsen ## Last Modified On: Thu Dec 07 08:59:15 2006 ## Update Count : 144 ## Status : Unknown, Use with caution! ############################################################################### ## ## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### makesimprob <- function(nw, s2=function(idx,cf) { cf <- as.vector(cf) xs <- (1:length(cf)) log(xs%*%cf+1) }, m0=function(idx,cf) { cf <- as.vector(cf) xs <- (1:length(cf))^2 .69*(xs%*%cf) }, m1=function(idx,cf) { cf <- as.vector(cf) xs <- (1:length(cf))*10 idx*(cf%*%xs) }) { ## sets up (and asks user for) probablities to simulate from ## ## Idea: let s2 and m1 depend on the node-index and on j ## Perhaps passing functions as arguments? ## ## Discrete variables are organised as follows ## The table always has the node itself as the first one. The ## remaining (conditioning) are sorted according to their index. We ## let the probabilities be equal. for (nid in 1:nw$n) { node <- nw$nodes[[nid]] parents <- node$parents if (nw$nd>0) dparents<- sort(intersect(parents,nw$discrete)) else dparents <- c() if (nw$nc>0) cparents<- sort(intersect(parents,nw$continuous)) if (length(dparents)>0) { Dim <- c() dnames <- list(node$levelnames) for (i in dparents) { Dim <- c(Dim,nw$nodes[[i]]$levels) dnames <- c(dnames,list(nw$nodes[[i]]$levelnames)) } TD <- prod(Dim) ## create labels lvek <- c() for (i in 1:TD) { cf <- findex( i, Dim, FALSE) label <- "" for (j in 1:ncol(cf)) { label <- paste(label, nw$nodes[[dparents[j]]]$levelnames[cf[1,j]] ,sep=":") } lvek <- c(lvek,label) } } else { dnames <- list(node$levelnames) TD <- 1 Dim <- c() } if (node$type=="continuous") { M <- matrix(NA,TD,1+1+length(cparents)) if (length(dparents)>0) rownames(M) <- lvek colnames(M) <- c("s2","m0",names(nw$nodes[cparents])) for (it in 1:nrow(M)) { ifelse(TD>1,cf <- findex( it, Dim, FALSE), cf <- 1) M[it,1] <- s2(nid,cf) M[it,2] <- m0(nid,cf) if (length(cparents)>0) { for (itt in 1:length(cparents)) M[it,3:(2+itt)] <- m1(nid,cf) } } nw$nodes[[nid]]$simprob <- M } else if (node$type=="discrete") { Dim <- c(node$levels,Dim) simtab <- array(1/prod(Dim),dim=Dim) dimnames(simtab) <- dnames if (length(node$parents)>0) simtab <- prop.table(simtab,2:(length(node$parents)+1)) nw$nodes[[nid]]$simprob <- simtab } else stop("makesimprob: Type is wrong") } nw } deal/R/learning.R0000644000175100001440000002625212101441102013311 0ustar hornikusers## learning.R ## Author : Claus Dethlefsen ## Created On : Mon Jan 14 12:24:13 2002 ## Last Modified By: Claus Dethlefsen ## Last Modified On: Mon Jan 12 14:32:52 2004 ## Update Count : 551 ## Status : Unknown, Use with caution! ############################################################################### ## ## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### learn <- function(nw, df, prior=jointprior(nw), nodelist=1:size(nw),trylist= vector("list",size(nw)), timetrace=FALSE ) { ## nw: network to be learned (condprior must be present in the nodes) ## df: dataframe with observations ## nodelist: vector of node-indices of nodes to be learned (default ## is to learn all nodes) ## trylist: a list of networks wherefrom some learning may be reused ## ## Returns a network with the following attributes ## score: calculated (or updated) network-score ## for each node in nodelist: ## loglik: the log-likelihood contribution of the node ## cond: updated posterior parameters ## ## Uses: cond, learnnode ## and network attributes: nodes, score is updated ## and node attributes: condprior,condposterior is updated ## ## Used by: insert,remover,removearrow,turnarrow, ## manualsearch,networkfamily, ## turnrandomarrow,deleterandomarrow (perturb) if (timetrace) {t1 <- proc.time();cat("[Learn.network ")} old <- df for (i in nodelist) { node <- nw$nodes[[i]] ## use trylist if (!is.null(trylist[[node$idx]])) { cur <- paste(node$parents,collapse=":") curm <- match(cur,trylist[[node$idx]][,1]) if (!is.na(curm)) { nw$nodes[[i]]$loglik <- as.numeric(trylist[[node$idx]][curm,2]) break } } ## learning node <- cond.node(node,nw,prior) ## master prior procedure node$condposterior <- node$condprior ## reset posterior node$loglik <- 0 node <- learnnode(node,nw,df,timetrace=FALSE)## learn! ## update trylist streng <- paste(node$parents,collapse=":") tal <- node$loglik if (is.null(trylist[[i]])) { trylist[[i]] <- cbind(streng,tal) } else trylist[[i]] <- rbind(trylist[[i]],cbind(streng,tal)) ## update network nw$nodes[[i]] <- node } ## calculate network score nw$score <- 0 for (i in 1:nw$n) nw$score <- nw$score + nw$nodes[[i]]$loglik if (timetrace) { t2 <- proc.time() cat((t2-t1)[1],"]") } list(nw=nw,trylist=trylist) } learnnode <- function(node,nw,df,prior=jointprior(nw),timetrace=FALSE) { ## node: node to be learned. condprior must be present ## nw: network ## df: dataframe to learn from ## ## Returns: node with extra (or updated) attributes: ## loglik: the loglikelihood contribution from this node ## cond: the posterior parameters ## ## Uses: udisclik,postc0c,postcc ## And network attributes: nc,nd,continuous,discrete,nodes ## And node attributes: type,condprior,condposterior ## (updated),loglik (updated),parents,levels,idx ## ## Used by: learn.network if (timetrace) {t1 <- proc.time();cat("[Learn.node ")} ## discrete nodes: if (node$type=="discrete") { node$condposterior[[1]]$alpha <- node$condprior[[1]]$alpha+ as.array(table(df[,sort(c(node$idx,node$parents))])) node$loglik <- udisclik(node,nw,df) ## batch update likelihood term node <- postdist.node(node,nw) if (timetrace) { t2 <- proc.time() cat((t2-t1)[1],"]") } return(node) } ## continuous nodes: ## 0 parents if (!length(node$parents)>0) { res <- postc0c(node$condposterior[[1]]$mu, node$condposterior[[1]]$tau, node$condposterior[[1]]$rho, node$condposterior[[1]]$phi, df[,node$idx]) ## Alternatively, use this (pure R) ## ## res <- post0(node$condposterior[[1]]$mu, ## node$condposterior[[1]]$tau, ## node$condposterior[[1]]$rho, ## node$condposterior[[1]]$phi, ## df[,node$idx]) node$condposterior[[1]]$mu <- res$mu node$condposterior[[1]]$tau <- res$tau node$condposterior[[1]]$rho <- res$rho node$condposterior[[1]]$phi <- res$phi node$loglik <- res$loglik node <- postdist.node(node,nw) return(node) } parents <- node$parents if (nw$nc>0) cparents<- sort(intersect(parents,nw$continuous)) else cparents <- c() if (nw$nd>0) dparents<- sort(intersect(parents,nw$discrete)) else dparents <- c() if (length(dparents)>0& (!length(cparents)>0)) { ## cat("Discrete parents, no Cont. parents\n") ## cat("dparents=",dparents,"\n") mscore <- 0 Dim <- c() for (i in dparents) Dim <- c(Dim,nw$nodes[[i]]$levels) for (j in 1:prod(Dim)) { cf <- findex(j,Dim,config=FALSE) idx <- 1:nrow(df) for (k in 1:length(dparents)) { pcf <- nw$nodes[[dparents[k]]]$levelnames[cf[1,k]] idx <- idx[df[idx,dparents[k]]==pcf] } ## for k if (length(idx)>0) { mu <- node$condposterior[[j]]$mu tau <- node$condposterior[[j]]$tau rho <- node$condposterior[[j]]$rho phi <- node$condposterior[[j]]$phi y <- df[idx,node$idx] res <- postc0c(mu, tau, rho, phi, y) ## Alternative (pure R): ## res <- post0(mu, tau, rho, phi, y) node$condposterior[[j]]$mu <- res$mu node$condposterior[[j]]$tau <- res$tau node$condposterior[[j]]$rho <- res$rho node$condposterior[[j]]$phi <- res$phi mscore <- mscore + res$loglik } } ## for j node$loglik <- mscore node <- postdist.node(node,nw) return(node) } if (!length(dparents)>0&length(cparents)>0) { ## cat("Continuous parents\n") res <- postcc(node$condposterior[[1]]$mu, node$condposterior[[1]]$tau, node$condposterior[[1]]$rho, node$condposterior[[1]]$phi, df[,node$idx], cbind(1,df[,cparents])) ## Alternative (pure R): # res <- post(node$condposterior[[1]]$mu, # node$condposterior[[1]]$tau, # node$condposterior[[1]]$rho, # node$condposterior[[1]]$phi, # df[,node$idx], # cbind(1,df[,cparents])) node$condposterior[[1]]$mu <- res$mu node$condposterior[[1]]$tau <- res$tau node$condposterior[[1]]$rho <- res$rho node$condposterior[[1]]$phi <- res$phi node$loglik <- res$loglik node <- postdist.node(node,nw) return(node) } if (length(dparents)>0&length(cparents)>0) { ## cat("Mixed parents\n") mscore <- 0 Dim <- c() for (i in dparents) Dim <- c(Dim,nw$nodes[[i]]$levels) for (j in 1:prod(Dim)) { cf <- findex(j,Dim,config=FALSE) idx <- 1:nrow(df) for (k in 1:length(dparents)) { pcf <- nw$nodes[[dparents[k]]]$levelnames[cf[1,k]] idx <- idx[df[idx,dparents[k]]==pcf] } ## for k if (length(idx)>0) { mu <- node$condposterior[[j]]$mu tau <- node$condposterior[[j]]$tau rho <- node$condposterior[[j]]$rho phi <- node$condposterior[[j]]$phi y <- df[idx,node$idx] z <- cbind(1,df[idx,cparents]) res <- postcc(mu, tau, rho, phi, y, z) ## Alternative (pure R): ## res <- post(mu, tau, rho, phi, y, z) node$condposterior[[j]]$mu <- res$mu node$condposterior[[j]]$tau <- res$tau node$condposterior[[j]]$rho <- res$rho node$condposterior[[j]]$phi <- res$phi mscore <- mscore + res$loglik } } ## for j node$loglik <- mscore node <- postdist.node(node,nw) return(node) } } udisclik <- function(node,nw,df) { ## update likelihood term for the discrete nodes alpha <- node$condposterior[[1]]$alpha cprior <- node$condprior[[1]]$alpha n <- sum(cprior) # img.db size N <- sum(alpha) # n+#obs nobs <- N-n if (length(node$parents)>0) { ## we have parents! idx <- sort(c(node$idx,node$parents)) cidx <- 1:length(idx) pidx <- cidx[-match(node$idx,idx)] ## alpha_{+d|i_pa(d)} ## alphaj <- table(cprior,pidx) alphaj <- apply(cprior,pidx,sum) ## alpha_{+d|i_pa(d)}+n_{+d|i_pa(d)} condj <- alphaj + as.array(table(df[,node$parents])) ## tres <- prod(gamma(condj)/gamma(alphaj)) logtres <- -sum( lgamma(condj) - lgamma(alphaj) ) ## res[[i]] <- tres * prod(gamma(alpha)/gamma(cprior)) res <- logtres + sum( lgamma(alpha) - lgamma(cprior) ) }## if parents else { ## no parents ## res[[i]] <- prod(gamma(alpha)/gamma(cprior))*gamma(n)/gamma(N) res <- sum( lgamma(alpha) - lgamma(cprior)) + lgamma(n)-lgamma(N) } ## res[[i]] <- log(res[[i]]) res } deal/R/jointprior.R0000644000175100001440000001237112101441102013706 0ustar hornikusers## jointprior.R ## Author : Claus Dethlefsen ## Created On : Tue Nov 27 09:03:14 2001 ## Last Modified By: Claus Dethlefsen ## Last Modified On: Wed Jul 23 10:12:21 2003 ## Update Count : 195 ## Status : Unknown, Use with caution! ############################################################################### ## ## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### jointprior <- function(nw,N=NA,phiprior="bottcher", timetrace=FALSE) { ## Setup a joint prior distribution for the parameters ## phiprior="bottcher" or "heckerman" ## ## The parameters for the discrete part of the network are stored in ## multi-way arrays. ## The parameters for the mixed part of the network are stored in ## a matrix (mu) and lists with one row or entry per configuration ## of the discrete variables. ## For translation back and forth between configurations of the ## discrete variables and the entry number in the matrix/list, see ## the findex function. if (timetrace) {t1 <- proc.time();cat("[Jointprior ")} ## ############################################## ## Parameters for discrete variables ## ############################################## ## jointalpha if (nw$nd>0) { ## at least one discrete node jointprob <- jointdisc(nw,timetrace=timetrace) ## determine smallest possible imaginary sample size ## and reset it if too small. minN <- min(2/jointprob) if (is.na(N)) N <- minN if (N0) { ## at least one cont. node NN <- prod(dim(jointalpha)) ## create labels if (nw$nd>0) { Dim <- dim(jointalpha) dparents <- nw$discrete lvek <- c() for (i in 1:NN) { cf <- findex( i, Dim, FALSE) label <- "" for (j in 1:ncol(cf)) { label <- paste(label, nw$nodes[[dparents[j]]]$levelnames[cf[1,j]] ,sep=":") } lvek <- c(lvek,label) } } jointmu <- matrix(NA,NN,nw$nc) jointsigma <- list() jointphi <- list() ## generate mu-vector and sigma2-vector jcont <- jointcont(nw,timetrace=timetrace) jointmu <- jcont$mu jointsigma <- jcont$sigma2 dnames <- colnames(jointmu) for (i in 1:NN) { if (phiprior=="bottcher") { jointphi[[i]] <- jointsigma[[i]] * (jointnu[i]-1) } else { if (phiprior=="heckerman") { jointphi[[i]] <- (jointrho[i]-2)/(jointnu[i]+1)* jointnu[i]*jointsigma[[i]] } else stop("No such phiprior implemented") } ## set names colnames(jointmu) <- dnames colnames(jointsigma[[i]]) <- dnames rownames(jointsigma[[i]]) <- dnames colnames(jointphi[[i]]) <- dnames rownames(jointphi[[i]]) <- dnames } ## Set names on the list if (nw$nd>0) { names(jointsigma) <- lvek names(jointphi) <- lvek rownames(jointmu) <- lvek } } else { ## no cont. nodes jointphi <- NA jointmu <- NA jointsigma <- NA } if (timetrace) { t2 <- proc.time() cat((t2-t1)[1],"]\n") } list(jointalpha=jointalpha, jointnu=jointnu, jointrho=jointrho, jointmu=jointmu,jointsigma=jointsigma,jointphi=jointphi) } deal/R/jointdisc.R0000644000175100001440000000642412101441102013477 0ustar hornikusers## jointdisc.R --- ## Author : Claus Dethlefsen ## Created On : Wed Mar 06 12:52:57 2002 ## Last Modified By: Claus Dethlefsen ## Last Modified On: Mon Dec 15 12:05:40 2008 ## Update Count : 31 ## Status : Unknown, Use with caution! ############################################################################### ## ## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### jointdisc <- function(nw,timetrace=FALSE) { ## From the discrete part of nw, the joint distribution is ## determined from the local distributions in nodes$prob. ## ## If eg. A|B,C, B|C, C are given, the joint distribution of A,B,C ## is returned ## if (timetrace) {t1 <- proc.time();cat("[jointdisc ")} ## First, determine the discrete nodes and their dimensions Dim <- c() lablist <- list() for (i in nw$discrete) { Dim <- c(Dim, nw$nodes[[i]]$levels) lablist <- c(lablist,list(nw$nodes[[i]]$levelnames)) } ## Dim is the dimension of the returned joint distribution jointprob <- array(1,Dim) dimnames(jointprob) <- lablist ## for each node, multiply jointprob by the local distribution ## (blown up appropriately). for (nid in nw$discrete) { node <- nw$nodes[[nid]] Pn <- node$prob ## the local distribution parents <- node$parents ## the parents, if (nw$nd>0) dparents<- sort(intersect(parents,nw$discrete)) else dparents <- c() idx <- c(node$idx, dparents) ## sequence in Pn pidx<- 1:length(idx) ## corresponding idx jidx<- 1:nw$nd ## idx in jointprior ## dimension of c(node,parents) nDim <- c(node$levels) for (i in dparents) nDim <- c(nDim,nw$nodes[[i]]$levels) ## blow up ## first, permute Dim appropriately ivek <- c(pidx,setdiff(jidx,pidx)) # ivek <- c(idx,setdiff(jidx,idx)) # changed 25/6-2007 due to ## Jean-Baptiste DENIS jDim <- Dim[ivek] bigPn <- array(Pn,jDim) ## permute indices appropriately permvek <- match(1:nw$nd,ivek) bigPn <- aperm(bigPn, permvek) jointprob <- jointprob * bigPn } ## for if (timetrace) { t2 <- proc.time() cat((t2-t1)[1],"]") } jointprob } ## function discjoint deal/R/jointcont.R0000644000175100001440000001720212101441102013514 0ustar hornikusers## jointcont.R ## Author : Claus Dethlefsen ## Created On : Wed Mar 06 12:52:57 2002 ## Last Modified By: Claus Dethlefsen ## Last Modified On: Sun Jul 27 15:57:54 2003 ## Update Count : 333 ## Status : Unknown, Use with caution! ############################################################################### ## ## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### jointcont <- function(nw,timetrace=FALSE) { ## From the continuous part of nw, the joint distribution is ## determined from the local distributions in nodes$prob. ## ## If eg. x|y,z, y|z, z are given, the joint distribution of x,y,z ## is returned ## if (timetrace) {t1 <- proc.time();cat("[jointcont ")} ## First, determine the discrete nodes and their dimensions Dim <- c() TD <- 1 if (nw$nd>0) { for (i in nw$discrete) { Dim <- c(Dim, nw$nodes[[i]]$levels) } TD <- prod(Dim) } ## create labels for the configurations of the discrete variables lablist <- c() if (nw$nd>0) { for (i in 1:TD) { cf <- findex( i, Dim, FALSE) label <- "" for (j in 1:ncol(cf)) { label <- paste(label, nw$nodes[[nw$discrete[j]]]$levelnames[cf[1,j]] ,sep=":") } lablist <- c(lablist,label) } } ## determine the continuous nodes lab <- c() for (i in nw$continuous) lab <- c(lab,nw$nodes[[i]]$name) mu <- matrix(0,TD,nw$nc) sigma2 <- matrix(0,nw$nc,nw$nc) sigma2list <- list() colnames(mu) <- lab rownames(mu) <- lablist rownames(sigma2) <- colnames(sigma2) <- lab for (i in 1:TD) sigma2list[[i]] <- sigma2 names(sigma2list) <- lablist calclist <- c() allnodes <- c(nw$continuous) nidx <- 0 while ( length( setdiff(allnodes,calclist) )>0 ) { ## the main loop. Evaluates nodes sequentially so that the ## parents of the current node has already been evaluated nidx <- nidx%%(nw$nc)+1 nid <- nw$continuous[nidx] if ( length(intersect(nid,calclist))>0) { next } node <- nw$nodes[[nid]] Pn <- node$prob ## the local distribution parents <- node$parents ## the parents, if (nw$nc>0) cparents<- sort(intersect(parents,nw$continuous)) else cparents <- c() if (nw$nd>0) dparents<- sort(intersect(parents,nw$discrete)) else dparents <- c() if ( length( setdiff(cparents,calclist) ) > 0 ) { next } ## calculate unconditional mu, sigma2 from node|parents if (!length(cparents)>0) { M <- array(1:TD,dim=Dim) if (length(dparents)>0) { mdim <- c() for (i in dparents) mdim <- c(mdim,nw$nodes[[i]]$levels) m <- array(1:TD,dim=mdim) ## inflate ## first, permute Dim appropriately ivek <- c(match(dparents,nw$discrete), match(setdiff(nw$discrete,dparents),nw$discrete)) jDim <- Dim[ivek] bigM <- array(m,jDim) ## permute back permvek <- match(1:nw$nd,ivek) bigM <- aperm(bigM, permvek) for (i in 1:length(unique(c(bigM)))) { theidx <- M[bigM==i] cf <- findex(theidx,Dim,config=FALSE) cfm<- cf[,match(dparents,nw$discrete)] cfm <- matrix(cfm,nrow=length(theidx)) theidxm <- findex(cfm,mdim,config=TRUE) paridx <- match(1:nw$nc,c(nid,cparents)) for (k in 1:length(theidx)) { mu[theidx,nidx] <- Pn[theidxm[k],2] sigma2list[[theidx[k]]][nidx,nidx] <- Pn[theidxm[k],1] } } } else { ## no discrete parents for (i in 1:TD) { mu[i,nidx] <- Pn[2] sigma2list[[i]][nidx,nidx] <- Pn[1] } } ## end else (no discrete parents) } else { # we have continuous (and possibly discrete) parents for (k in 1:TD) { if (length(dparents)>0) { mdim <- c() for (i in dparents) mdim <- c(mdim,nw$nodes[[i]]$levels) Mcf <- findex(k,Dim,config=FALSE) didx <- match(dparents,nw$discrete) dcf <- Mcf[,didx] if (length(dcf)==2) dcf <- matrix(dcf,ncol=2) kidx <- findex(dcf,mdim,config=TRUE) } else kidx <- 1 ## parentidx: index in mu,sigma2list of parents ## calcidx: index in mu,sigma2list of processed nodes parentidx <- match(cparents,nw$continuous) calcidx <- match(sort(calclist),nw$continuous) if (!length(dparents)>0) { m.ylx <- Pn[2] s2.ylx<- Pn[1] b.ylx <- Pn[3:length(Pn)] } else { m.ylx <- Pn[kidx,2] s2.ylx<- Pn[kidx,1] b.ylx <- Pn[kidx,3:ncol(Pn)] } m.x <- mu[k,parentidx] s2.x <- sigma2list[[k]][parentidx,parentidx] pid <- match(parentidx,sort(calclist)) pid <- pid[!is.na(pid)] b.calc <- rep(0,length(calcidx)) b.calc[pid] <- b.ylx s2.calc <- sigma2list[[k]][calcidx,calcidx] s.xycalc <- s2.calc %*% b.calc s.xy <- s2.x %*% b.ylx s2.y <- s2.ylx + c(s.xy)%*%b.ylx m.y <- m.ylx + b.ylx%*%m.x mu[k,nidx] <- m.y sigma2list[[k]][nidx,nidx] <- s2.y sigma2list[[k]][calcidx,nidx] <- s.xycalc sigma2list[[k]][nidx,calcidx] <- t(s.xycalc) } } calclist <- c(calclist,nid) } ## while if (timetrace) { t2 <- proc.time() cat((t2-t1)[1],"]") } list(mu=mu,sigma2=sigma2list) } ## function discjoint deal/R/inspectprob.R0000644000175100001440000000743512101441102014044 0ustar hornikusers## inspectprob.R ## Author : Claus Dethlefsen ## Created On : Sun Feb 03 15:02:14 2002 ## Last Modified By: Claus Dethlefsen ## Last Modified On: Wed Jul 28 09:39:34 2004 ## Update Count : 35 ## Status : Unknown, Use with caution! ############################################################################### ## ## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### inspectprob <- function(nw,unitscale=20,cexscale=8, arrowlength=.25,xr=c(0,350),yr=xr,...) { ## arguments are the same as for plot.network. par(mfrow=c(1,1)) plot(x=nw,unitscale=unitscale,cexscale=cexscale,arrowlength=arrowlength,xr=xr,yr=yr,...) title("Inspect/Change initial probability distribution") xc <- mean(xr) yc <- mean(yr) points(xc,yc,cex=cexscale+4,pch=5) text(xc,yc,"Stop") mode <- "Inspect" newnet <- nw quit <- FALSE unit <- 2*pi/nw$n where <- t(matrix(unlist(lapply(newnet$nodes, function(x) x$position)),nrow=2)) where <- rbind(where,c(xc,yc)) buttonx <- 20 buttony <- 30 where <- rbind(where,c(2*xc-buttonx,2*yc)) where <- rbind(where,c(2*xc-buttonx,2*yc-buttony)) nlist <- names(nw$nodes) while(!quit) { if (mode=="Inspect") { bgadd <- "black"; fgadd <- "white"; bgrem <- "white"; fgrem <- "black"; } if (mode=="Change") { bgadd <- "white"; fgadd <- "black"; bgrem <- "black"; fgrem <- "white"; } symbols(2*xc-buttonx,2*yc,rectangles=matrix(c(2,1),1),add=TRUE,bg=bgadd) text(2*xc-buttonx,2*yc,"Inspect",col=fgadd) symbols(2*xc-buttonx,2*yc-buttony,rectangles=matrix(c(2,1),1),add=TRUE,bg=bgrem) text(2*xc-buttonx,2*yc-buttony,"Change",col=fgrem) from <- identify(where[,1],where[,2],rep("",nw$n+3),n=1) if (from==nw$n+1) break if (from==nw$n+2) { mode <- "Inspect"; next } if (from==nw$n+3) { mode <- "Change"; next } if (mode=="Change") { printline() cat(mode, "node",nlist[from],"\n") print(nw$nodes[[from]]$prob) cat("Want to change node",nlist[from],"\n") cat("Not yet implemented, sorry...\n") } else if(mode=="Inspect") { printline() cat(mode, "node",nlist[from],"\n") print(nw$nodes[[from]]$prob) } plot(newnet,unitscale=unitscale,cexscale=cexscale,arrowlength=arrowlength,xr=xr,yr=yr,...) title("Inspect/Change initial probability distribution") points(xc,yc,cex=cexscale+4,pch=5) text(xc,yc,"Stop") } plot(newnet,unitscale=unitscale,cexscale=cexscale,arrowlength=arrowlength,xr=xr,yr=yr,...) newnet } deal/R/heuristic.R0000644000175100001440000001060412101441102013503 0ustar hornikusers## heuristic.R ## Author : Claus Dethlefsen ## Created On : Sun Jan 13 11:23:16 2002 ## Last Modified By: Claus Dethlefsen ## Last Modified On: Thu Dec 04 12:43:46 2008 ## Update Count : 149 ## Status : Unknown, Use with caution! ############################################################################### ## ## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### heuristic <- function(initnw,data,prior=jointprior(network(data)), maxiter=100,restart=10,degree=size(initnw), trylist= vector("list",size(initnw)),trace=TRUE, timetrace=TRUE,removecycles=FALSE) { ## Heuristic search with random restart ## initnw: an initial network (already learned) ## data: dataframe ## prior: your favorite prior (has a default) ## maxiter:Max search steps in the search algorithm ## restart:The number of times to perturb initnw and rerun the search ## degree: Degree of perturbation ## trace=F: Do not plot ## outputs: The network with highest likelihood, ## A list of start and end networks in the restart ## A list of all networks tried if (timetrace) {t1 <- proc.time();cat("[Heuristic ")} if (timetrace) s1 <- proc.time()[3] nwl <- autosearch(initnw, data,prior, maxiter, trylist, trace=trace,timetrace=TRUE, removecycles=removecycles) nw <- nwl$nw trylist <- nwl$trylist table <- nwl$table if (timetrace) { s2 <- proc.time()[3] sauto <- s2-s1 spert <- 0 suniq <- 0 } if (restart>0) { for (i in 1:restart) { if (timetrace) s3 <- proc.time()[3] nw <- perturb(initnw,data,prior,degree,trylist=trylist,timetrace=TRUE) trylist <- nw$trylist nw <- nw$nw ms <- modelstring(nw) if (timetrace) { s4 <- proc.time()[3] spert <- spert + s4-s3 } if (!is.na(match(ms,table[,1]))) next table <- rbind(table,cbind(ms,nw$score)) if (trace) { plot(nw) title("New network") } if (timetrace) s5 <- proc.time()[3] newnwl <- autosearch(nw,data,prior,maxiter, trylist=trylist,trace=trace,timetrace=TRUE,removecycles=removecycles) trylist <- newnwl$trylist table <- rbind(table,newnwl$table) if (timetrace) { s6 <- proc.time()[3] sauto <- sauto + s6-s5 } if (timetrace) s7 <- proc.time()[3] table <- table[!duplicated(table[,1]),] table <- table[sort.list(-as.numeric(table[,2])),] if (timetrace) { s8 <- proc.time()[3] suniq <- suniq + s8 - s7 } } ## for i } ## if restart if (initnw$n<15) antal <- paste(numbermixed(initnw$nc,initnw$nd)) else antal <- "many" cat("Tried",nrow(table),"out of approx.",antal,"networks\n") if (timetrace) { t2 <- proc.time() cat((t2-t1)[1],"]\n") cat("Perturb:",spert,",Autosearch:",sauto,",Unique:",suniq,"\n") } thebest <- as.network(table[1,],initnw) thebest <- learn(thebest,data,prior)$nw list(nw=thebest,table=table,trylist=trylist) } deal/R/genlatex.R0000644000175100001440000001427112101441102013317 0ustar hornikusers## genlatex.R --- ## Author : Claus Dethlefsen ## Created On : Tue May 07 10:10:39 2002 ## Last Modified By: Claus Dethlefsen ## Last Modified On: Thu Nov 03 13:34:12 2005 ## Update Count : 48 ## Status : Unknown, Use with caution! ############################################################################### ## ## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### genlatex <- function(nwl, outdir="pic/", prefix="scoretable", picdir="", picpre="pic", ncol=5, nrow=7, width=12/ncol, vadjust=-1.8) { ## Create latex-table of pictex figures with references to the ## generated pictex-files. ## ## nwl: networkfamily ## outdir: where the file is stored ## prefix: the filename minus extension (which is .tex) ## picdir: where to find the picfiles (the path is inserted in the ## latex files) ## picpre: the filenames of the picfiles are 'picpre'xx.pic, where ## xx is the index of the network ## ncol: the number of columns in the table ## nrow: the number of rows in the table ## width: the width of each cell in the table ## vadjust: Vertical adjustment ## uses: fmt+findexponent defined locally ## and network-attributes: score, relscore findexponent <- function(x) { ## find exponent: n <- 0 y <- x while (floor(y)==0) { n <- n+1 y <- y*10 } n } fmt <- function(x,digits=2) { ## format a number to a LaTeX string in scientific notation ## Used by: genlatex if (x==1) return("\\footnotesize{$1$}") if (x==0) return("\\footnotesize{$0$}") n <- findexponent(x) y <- x*10^n yy<- signif(y,digits) y <- as.character(signif(y,digits)) if ( (yy*10)%%10==0) y <- paste(y,".0",sep="") fod <- paste("\\footnotesize{$",y) expo <- ifelse(n==0, "",paste("\\cdot 10^{-",n,"}")) paste(fod,expo,"$}") } dir.create(outdir) ff <- file(paste(outdir,prefix,".tex",sep=""),"w") ## output filename ## filename of picfile i pf <- function(i) paste(picdir,picpre,i,".tex",sep="") ## how to include one picfile as a minipage with score and relscore putfig <- function(i) paste("\\vspace{",vadjust/2,"cm}", "\\begin{minipage}[t]{",width,"cm}\n", "\\input{",pf(i),"}\n", "\\vspace{",vadjust,"cm}", fmt(nwl[[i]]$score),"\\\\\n", fmt(nwl[[i]]$relscore),"\n", "\\end{minipage}\n",sep="") finished <- FALSE cat("%% generated automatically",date(),"- Don't edit by hand\n",file=ff) cat("%% A master file:\n",file=ff) cat("%% \\documentclass{article}\n",file=ff) cat("%% \\usepackage{array,pictex}\n",file=ff) cat("%% \\begin{document}\n",file=ff) cat("%% \\input{scoretable}\n",file=ff) cat("%% \\end{document}\n",file=ff) fig <- 1 while (!finished) { ## header if (fig %% (ncol*nrow) == 1 || fig == 1) { cat("\\begin{tabular}{",file=ff) for (i in 1:ncol) cat("|m{",width,"cm}",sep="",file=ff) cat("|}\\hline\n",file=ff) } ## figs for (i in 1:ncol) { if (fig==length(nwl)) { cat(putfig(fig),"\\\\ \n\\hline",file=ff) finished <- TRUE; break } if (i %% ncol == 0) { cat(putfig(fig),"\\\\",file=ff) if (fig %% (ncol*nrow) != 0) cat("[-9mm]",sep="",file=ff) cat("\n\\hline",file=ff) } else cat(putfig(fig),"&\n",sep="",file=ff) fig <- fig + 1 } ## footer if (fig %% (ncol*nrow) == 1 || finished) cat("\\end{tabular}\\clearpage\n",file=ff) } close(ff) invisible() } genpicfile <- function(nwl,outdir="pic/",prefix="pic",w=1.6,h=1.6,bigscale=3) { ## Create latex-table of pictex figures with references to the ## generated pictex-files. ## ## nwl: networkfamily ## outdir: where the files are stored ## prefix: the filename prefix of all files ## w: width of pictex object ## h: height of pictex object ## bigscale: scaling of the best network, which is output in 'nice.tex' ## uses: plot.network cat("\nGenerating pic-files...") dir.create(outdir) ## the best pictex( paste(outdir,prefix,"nice.tex",sep=""), width=w*bigscale,height=h*bigscale ) plot(nwl[[1]]) dev.off() ## the rest for (i in 1:length(nwl)) { name <- paste(outdir,prefix,i,".tex",sep="") pictex(name,width=w,height=h) plot(nwl[[i]],cexscale=3,arrowlength=0.05,notext=TRUE) dev.off() } cat("complete\n") } deal/R/generic.R0000644000175100001440000000552512101441102013126 0ustar hornikusers## generic.R ## Author : Claus Dethlefsen ## Created On : Mon Nov 19 20:48:24 2001 ## Last Modified By: Claus Dethlefsen ## Last Modified On: Tue Nov 01 13:46:57 2011 ## Update Count : 109 ## Status : Unknown, Use with caution! ############################################################################### ## ## Copyright (C) 2002 Susanne Gammelgaard Bottcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### printline <- function(s="-",n=60) cat(rep(s,n),"\n",sep="") #.First.lib <- function(lib, pkg) #{ # require(methods) # require(dynamicGraph) # library.dynam("deal", package = pkg, lib.loc = lib) # if((R.version$major == 1) && (as.numeric(R.version$minor) < 9)) # packageDescription <- package.description # cat("\n") # cat("-------------------------------------------------------------\n") # cat(packageDescription("deal", lib = lib, field="Title")) # cat("\n") # ver <- packageDescription("deal", lib = lib, field="Version") # maint<- packageDescription("deal", lib = lib, field="Maintainer") # built<- packageDescription("deal", lib = lib, field="Built") # URL <- packageDescription("deal", lib = lib, field="URL") # cat(paste("deal, version", ver, "is now loaded\n")) # cat("Copyright (C) 2002-2007, Susanne G. Bottcher and Claus Dethlefsen\n") # cat("Maintained by",maint,"\n") # cat("Webpage:",URL,"\n") # cat("\nBuilt:",built,"\n") # cat("-------------------------------------------------------------\n") # cat("\n") # require(methods) # .load.deal.networkclass() # .load.dynamicgraph() # return(invisible(0)) #} .onAttach <- function (lib, pkg) { # require(methods) # .load.deal.networkclass() # library.dynam("deal", package = pkg, lib.loc = lib) } .onLoad <- function (lib, pkg) { # require(methods) # .load.deal.networkclass() library.dynam("deal", package = pkg, lib.loc = lib) } #.Last.lib <- function(lib) { # cat("Thank you for using deal\n") # return(invisible(0)) #} deal/R/fullsimprob.R0000644000175100001440000000517112101441102014045 0ustar hornikusers## Author: Jim Young ## Version of 'makesimprob' that samples from Dirichlet posterior rather than # using the expected value - see 'Bayesian data analysis' Gelman, # Carlin, Stern and Rubin 1995 p482. fullsimprob <- function (nw) { for (nid in 1:nw$n) { node <- nw$nodes[[nid]] if (node$type == "continuous") stop("fullsimprob only works for discrete nodes") parents <- node$parents dparents <- c() if (nw$nd > 0) dparents <- sort(intersect(parents, nw$discrete)) if (length(dparents) > 0) { Dim <- c() dnames <- list(node$levelnames) for (i in dparents) { Dim <- c(Dim, nw$nodes[[i]]$levels) dnames <- c(dnames, list(nw$nodes[[i]]$levelnames)) } } if (identical(length(dparents),as.integer(0))) { dnames <- list(node$levelnames) Dim <- c() } # Additional code to extract conditional posterior frequencies and re-sort. # Set up an empty array to hold dimensions of conditional posterior. CDim <- c() # Re-order node and its discrete parents into network order. netorder <- sort(union(nid, dparents)) # Find dimensions of these nodes in network order. for (i in netorder) { CDim <- c(CDim, nw$nodes[[i]]$levels) } # Pull conditonal posterior counts out of the network for this node. condP <- array(unlist(node$condposterior),dim=CDim) # Sampling from a Dirichlet distribution with parameters alpha - see Gelman # Carlin, Stern and Rubin p 482: draw x's from independent gamma distributions # with shape parameters alpha and common scale, then thetas equal each x # divided by the sum of all x's. condP <- array(rgamma(n=length(unlist(condP)),shape=condP,scale=1), dim=CDim) condP <- condP/sum(unlist(condP)) # End of Dirichlet sampling code. The last line appears to be unnecessary. # The next line is critical ? reorder into dimensions expected by ?rnetwork?. # If there are parents, turn array around using order of node then parents. if (length(dparents) > 0) condP <- aperm(condP, rank(c(nid,dparents))) Dim <- c(node$levels, Dim) # Next line, instead of ?simtab <- array(1/prod(Dim), dim = Dim)? # use the conditional posterior probabilities? simtab <- condP dimnames(simtab) <- dnames if (length(node$parents) > 0) simtab <- prop.table(simtab, 2:(length(node$parents) + 1)) else simtab <- prop.table(simtab) nw$nodes[[nid]]$simprob <- simtab } nw } deal/R/findex.R0000644000175100001440000000531312101441102012762 0ustar hornikusers## findex.R ## Author : Claus Dethlefsen ## Created On : Thu Nov 29 10:15:11 2001 ## Last Modified By: Claus Dethlefsen ## Last Modified On: Tue Jul 22 16:53:14 2003 ## Update Count : 67 ## Status : Unknown, Use with caution! ############################################################################### ## ## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### findex <- function(i, dim, config=TRUE) { ## find index for use with an array of dimension 'dim' ## ## if config==T :: (i is a configuration matrix) ## i is then interpreted as a ## matrix with one row per wanted entry. The columns are the ## configurations of each of the discrete variables (in the proper ## order). ## Returned is a vector of length the number of rows of i. The ## entries correspond to each row and is the corresponding number if ## the array were 'folded' out. ## ## if config==F :: ## i is a vector of indices in the unfolded array. We want the ## corresponding configurations of the discrete variables ## output is a matrix with one row per configuration ## ## Thus, findex(config=T) and findex(config=F) are each others ## inverse functions mymod <- function(a,n) ifelse(a%%n==0,a%%n+n,a%%n) roundup <- function(a) floor(a+0.999) N <- prod(dim) D <- length(dim) if (config) res <- array(1:N,dim=dim)[i] else { ## Like V&R page 42 res <- matrix(NA,length(i),D) for (k in 1:length(i)) { j <- i[k] res[k,1] <- mymod(j,dim[1]) if (D>1) { for (s in 2:D) res[k,s] <- roundup(mymod(j,prod(dim[1:s]))/ prod(dim[1:(s-1)])) } } } res } deal/R/drawnetwork.R0000644000175100001440000002035712101441102014061 0ustar hornikusers## drawnetwork.R ## Author : Claus Dethlefsen ## Created On : Fri Nov 30 22:05:59 2001 ## Last Modified By: Claus Dethlefsen ## Last Modified On: Mon Jan 12 14:31:50 2004 ## Update Count : 292 ## Status : Unknown, Use with caution! ############################################################################### ## ## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### drawnetwork <- function(nw, df, prior, trylist=vector("list",size(nw)), unitscale=20, cexscale=8, arrowlength=.25, nocalc=FALSE, yr=c(0,350), xr=yr, ...) { ## arguments are the similar as for plot.network. ## nocalc=T: don't calculate scores (for use with 'specifynetwork') par(mfrow=c(1,1)) plot(nw,unitscale=unitscale, cexscale=cexscale,arrowlength=arrowlength, showban=TRUE,xr=xr,yr=yr,...) xc <- mean(xr) yc <- mean(yr) points(xc,yc,cex=cexscale+4,pch=5) text(xc,yc,"Stop") mode <- "Add" banmode <- FALSE movemode <- FALSE if (length(nw$banlist)>0) banlist <- nw$banlist else banlist <- matrix(0,0,2) newnet <- nw quit <- FALSE unit <- 2*pi/nw$n nlist <- names(nw$nodes) while(!quit) { where <- t(matrix( unlist( lapply(newnet$nodes, function(x)x$position) ), nrow=2)) buttonx <- 20 buttony <- 30 where <- rbind(where,c(xc,yc)) where <- rbind(where,c(2*xc-buttonx,2*yc)) where <- rbind(where,c(2*xc-buttonx,2*yc-buttony)) where <- rbind(where,c(2*xc-buttonx,2*yc-2*buttony)) where <- rbind(where,c(2*xc-buttonx,2*yc-3*buttony)) if (mode=="Add") { bgadd <- "black"; fgadd <- "white"; bgrem <- "white"; fgrem <- "black"; } if (mode=="Remove") { bgadd <- "white"; fgadd <- "black"; bgrem <- "black"; fgrem <- "white"; } if (movemode) { bgmove <- "black"; fgmove <- "white"; } else { bgmove <- "white"; fgmove <- "black"; } if (banmode) { bgban <- "black"; fgban <- "white";} else { bgban <- "white"; fgban <- "black"; } symbols(2*xc-buttonx,2*yc, rectangles=matrix(c(2,1),1),add=TRUE,bg=bgadd) text(2*xc-buttonx,2*yc,"Add",col=fgadd) symbols(2*xc-buttonx,2*yc-buttony, rectangles=matrix(c(2,1),1),add=TRUE,bg=bgrem) text(2*xc-buttonx,2*yc-buttony,"Remove",col=fgrem) symbols(2*xc-buttonx,2*yc-2*buttony, rectangles=matrix(c(2,1),1),add=TRUE,bg=bgban) text(2*xc-buttonx,2*yc-2*buttony,"Ban",col=fgban) symbols(2*xc-buttonx,2*yc-3*buttony, rectangles=matrix(c(2,1),1),add=TRUE,bg=bgmove) text(2*xc-buttonx,2*yc-3*buttony,"Move",col=fgmove) from <- identify(where[,1],where[,2],rep("",nw$n+5),n=1) if (from==nw$n+1) break if (from==nw$n+2) { mode <- "Add"; next } if (from==nw$n+3) { mode <- "Remove"; next } if (from==nw$n+4) { banmode <- !banmode;next } if (from==nw$n+5) { movemode <- !movemode;next } if (movemode) to <- unlist(locator(1)) else to <- identify(where[,1],where[,2],rep("",nw$n+5),n=1) if (to==nw$n+1) break if (to==nw$n+2) { mode <- "Add"; next } if (to==nw$n+3) { mode <- "Remove"; next } if (to==nw$n+4) { banmode <- !banmode;next } if (to==nw$n+5) { movemode <- !movemode;next } if (!movemode) { if (!banmode) { if (mode=="Add") { tempnet <- insert(newnet,from,to,df,prior,nocalc, trylist=trylist) } else if(mode=="Remove") tempnet <- remover(newnet,from,to,df,prior,nocalc, trylist=trylist) if (length(tempnet$nw)>0) { if (!cycletest(tempnet$nw)) { newnet <- tempnet trylist <- newnet$trylist newnet <- newnet$nw } else cat("Oh, no - you created a cycle. Try again\n") } else cat("something happened\n") } else { ## cat("banmode is on...\n") if (mode=="Add") { ## cat("Trying to add",from,"->",to,"to banlist\n") if (from==to) { cat("Can't add the arrow:",from,"->",to,"\n") next } else if (nw$nodes[[to]]$type=="discrete" & nw$nodes[[from]]$type=="continuous") { cat("Arrow (",from,"->",to,") illegal\n") next } else if (!is.na(match(from,newnet$nodes[[to]]$parents))) { cat("Can't add arrow(",from,"->",to,")\n", "it's already in the graph\n") next } banlist <- rbind(banlist,c(from,to)) } else if(mode=="Remove") { ## cat("Trying to remove",from,"->",to,"from banlist\n") if (!nrow(banlist)>0) { ## cat("nothing in banlist\n") next } idx <- (1:nrow(banlist))[banlist[,1]==from] if (!length(idx)>0) { ## cat("Not in banlist\n") next } if (!is.na(match(to,banlist[idx,2]))) { ## cat("removing from banlist\n") banlist <- banlist[-idx[match(to,banlist[idx,2])],] banlist <- matrix(banlist,ncol=2) next } ## cat("Its not in the banlist\n") } } } else { ## cat("changing (",nw$nodes[[from]]$position,") to (",to,")\n") newnet$nodes[[from]]$position <- to } newnet$banlist <- banlist plot(newnet,unitscale=unitscale,cexscale=cexscale, arrowlength=arrowlength,showban=TRUE,xr=xr,yr=yr,...) points(xc,yc,cex=cexscale+4,pch=5) text(xc,yc,"Stop") } plot(newnet,unitscale=unitscale, cexscale=cexscale,arrowlength=arrowlength, showban=TRUE,xr=xr,yr=yr,...) if (!nocalc) newnet <- learn(newnet,df,prior)$nw list(nw=newnet,trylist=trylist) } deal/R/cycletest.R0000644000175100001440000000624112101441102013505 0ustar hornikusers## cycletest.R ## Author : Claus Dethlefsen ## Created On : Fri Dec 21 14:04:58 2001 ## Last Modified By: Claus Dethlefsen ## Last Modified On: Sun Sep 15 08:05:24 2002 ## Update Count : 59 ## Status : Unknown, Use with caution! ############################################################################### ## ## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### cycletest <- function(nw) { ## Does nw contain a cycle? ## ## Algorithm: ## if nw$n == 1 return(F) ## else res <- findleaf(nw) ## res=0 if no leaf else idx of leaf ## if res==0 return(T) ## else nw <- (nw with node idx deleted) ## cycletest(nw) ## ## Uses: findleaf ## and network attributes: ## n,nodes ## Used by: networkfamily, drawnetwork, autosearch, ## addrandomarrow, turnrandomarrow if (nw$n == 1) { #cat("only one node\n"); return(FALSE)} else { res <- findleaf(nw) if (res == 0) { ## cat("No leaf found\n"); return(TRUE) } else { ## cat("deleting node: ",nw$nodes[[res]]$name,"\n") nw$nodes <- nw$nodes[-res] nw$n <- nw$n - 1 ## should update cont and disc, but I won't. Just be careful ## how you use the procedure! cycletest(nw) } } } findleaf <- function(nw) { ## find a node not being a parent to any other node ## ## Uses network attributes: n, nodes ## and node attributes: idx, parents ## ## Used by: cycletest jump <- FALSE for (i in 1:nw$n) { ## for each node for (j in 1:nw$n) { ## testing i against i (hmm) ## cat("Is",nw$nodes[[i]]$name,"parent to",nw$nodes[[j]]$name,"?") ## is i a parent to j? ## Here, it is necessary to use 'idx', since we have been ## deleting nodes. Thus the indices are no longer 1:n res <- match(nw$nodes[[i]]$idx, nw$nodes[[j]]$parents) if (!is.na(res)) { ## i is not a leaf jump <- TRUE break ## next i } } if (!jump) return(i) jump <- FALSE } ## did not find any res <- 0 res } deal/R/conditional.R0000644000175100001440000000770612101441102014020 0ustar hornikusers## conditional.R ## Author : Claus Dethlefsen ## Created On : Sun Dec 02 14:18:04 2001 ## Last Modified By: Claus Dethlefsen ## Last Modified On: Tue Jul 22 15:31:42 2003 ## Update Count : 291 ## Status : Unknown, Use with caution! ####################################################################### ## ## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### conditional.cont <- function(A,mu,nu,rho,phi) { ## Conditional distribution for continuous node with index A ## The master parameters mu, nu, rho and phi ## See Bottcher (2002) for details. B <- A ## renaming due to compatibility ## calculate conditional probabilities ## p. 14 in Bottcher ## A <- setdiff(1:ncol(phi),B) if (length(A)<1) A <- TRUE rho.BlA <- rho + length(A) phi.AA.inv <- solve(phi[A,A]) phi.tmp <- phi[B,A]%*%phi.AA.inv phi.BlA <- phi[B,B] - phi.tmp%*%phi[A,B] mu.BlA <- c(mu[B] - phi.tmp%*%mu[A], phi.tmp) tau.BlA.inv.11 <- 1/nu + t(mu[A])%*%phi.AA.inv%*%mu[A] tau.BlA.inv.22 <- phi.AA.inv tau.BlA.inv.12 <- -t(mu[A]%*%phi.AA.inv) tau.inv <- rbind(cbind(tau.BlA.inv.11,t(tau.BlA.inv.12)), cbind(tau.BlA.inv.12,tau.BlA.inv.22) ) tau <- solve(tau.inv) list(tau=tau,phi=phi.BlA,mu=mu.BlA,rho=rho.BlA) } conditional.disc <- function(A,master) { list(list(alpha=apply(master,A,sum))) } conditional <- function(A,master,nw) { ## From node index A and given the master prior, calculate the ## conditional of A given the parents. (In nw, we use parents, ## discrete and continuous) ## A is always 1-dimensional family <- sort(c(nw$nodes[[A]]$idx,nw$nodes[[A]]$parents)) ## didx and cidx are used as indices for A in the master didx <- match(A,intersect(family,nw$discrete)) didx <- didx[!is.na(didx)] cidx <- match(A,intersect(family,nw$continuous)) cidx <- cidx[!is.na(cidx)] if (nw$nodes[[A]]$type=="continuous") { cond <- list() if (!is.list(master$phi)) { cond[1] <- list(conditional.cont(cidx, master$mu, master$nu, master$rho, master$phi )) } else { for (i in 1:length(master$phi)) { cond[i] <- list(conditional.cont(cidx, master$mu[i,], master$nu[i], master$rho[i], master$phi[[i]] )) } } } else if (nw$nodes[[A]]$type=="discrete") { cond <- list(list(alpha=master$alpha)) } else stop("Wrong node type in conditional\n") cond } deal/R/autosearch.R0000644000175100001440000002417012101441102013645 0ustar hornikusers## autosearch.R ## Author : Claus Dethlefsen ## Created On : Fri Jan 11 10:54:00 2002 ## Last Modified By: Claus Dethlefsen ## Last Modified On: Thu Dec 04 12:43:15 2008 ## Update Count : 307 ## Status : Unknown, Use with caution! ############################################################################### ## ## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### autosearch <- function(initnw,data,prior=jointprior(network(data)),maxiter=50, trylist= vector("list",size(initnw)),trace=TRUE, timetrace=TRUE,showban=FALSE,removecycles=FALSE) { ## Greedy search ## initnw: initial network with conditionals calculated ## ## output: networklist: a sorted list of all tried networks. ## used by: heuristic. ## uses: addarrow,removearrow,turnarrow,nwfsort,cycletest ## initnw$score ## Algorithm: ## Create all networks with one arrow added (addarrow) ## Create all networks with one arrow turned (turnarrow) ## Create all networks with one arrow removed (removearrow) ## Calculated scores for all networks ## Choose the non-cyclic network that increases the score the most, ## or stop. if (timetrace) {t1 <- proc.time();cat("[Autosearch ") tadd <- 0 trem <- 0 ttur <- 0 tsor <- 0 tcho <- 0 } nw <- initnw model <- modelstring(initnw) score <- initnw$score slut <- FALSE it <- 0 hiscore <- initnw$score while (!slut & it < maxiter) { it <- it + 1 if (timetrace) {s1 <- proc.time()[1]} # cat("adding arrows\n") thisnwl.add <- addarrow(nw,data,prior,trylist=trylist) trylist <- thisnwl.add$trylist thisnwl.add <- thisnwl.add$nw if (timetrace) {s2 <- proc.time()[1]; tadd <- tadd+s2-s1 } # cat("removing arrows\n") thisnwl.rem <- removearrow(nw,data,prior,trylist=trylist) trylist <- thisnwl.rem$trylist thisnwl.rem <- thisnwl.rem$nw if (timetrace) {s3 <- proc.time()[1]; trem <- trem+s3-s2 } # cat("turning arrows\n") thisnwl.tur <- turnarrow(nw,data,prior,trylist=trylist) trylist <- thisnwl.tur$trylist thisnwl.tur <- thisnwl.tur$nw if (timetrace) {s4 <- proc.time()[1]; ttur <- ttur+s4-s3 } thisnwl <- c(thisnwl.add,thisnwl.rem,thisnwl.tur) class(thisnwl) <- "networkfamily" thisnwl <- nwfsort(thisnwl) if (timetrace) {s5 <- proc.time()[1]; tsor <- tsor+s5-s4 } ## remove cycles and then choose the best if (removecycles) { thisnwl <- thisnwl[!unlist(lapply(thisnwl,cycletest))] nwcand <- thisnwl[[1]] ## what if all of them contains cycles? They do not. } else { ## choose the 'best' and then check for cycle. kk <- 1 while (TRUE) { nwcand <- thisnwl[[kk]] kk <- kk + 1 if (!cycletest(nwcand)) break if (timetrace) cat(".") } } if (timetrace) {s6 <- proc.time()[1]; tcho <- tcho+s6-s5 } model <- c(model,unlist(lapply(thisnwl,modelstring))) score <- c(score,unlist(lapply(thisnwl,function(x) x$score))) if (nwcand$score > hiscore) { hiscore <- nwcand$score nw <- nwcand if (trace) {plot(nw,showban=showban) } cat("(",it,") ",hiscore," ",modelstring(nw),"\n",sep="") } else { slut <- TRUE } } ## end while if (timetrace) { t2 <- proc.time() total <- (t2-t1)[1] cat("Total",total,"add",tadd,"rem",trem,"turn",ttur,"sort",tsor,"choose",tcho,"rest",total-tadd-trem-ttur-tsor-tcho,"]\n") } table <- cbind(model,score) table <- table[sort.list(-as.numeric(table[,2])),] list(nw=learn(nw,data,prior)$nw,table=table,trylist=trylist) } modelstring <- function(x) { res <- "" g <- function(x) x$name for (j in 1:x$n) { nd <- x$nodes[[j]] res <- paste(res,"[",nd$name,sep="") if (length(nd$parents)>0) { res <- paste(res,"|", paste(unlist(lapply(x$nodes[nd$parents],g)), collapse=":"), sep="") } res <- paste(res,"]",sep="") } res } makenw <- function(tb,template) { res <- apply(tb,1,as.network,template) class(res) <- "networkfamily" nwfsort(res) } as.network <- function(nwstring,template) { x <- nwstring ## x: vector of (modelstring and score) ## from 'modelstring' (output from modelstring), create a network ## structure (not learned!) ## template is a network with the same nodes ## Thus, the function inserts the parent-relations that are ## described in mstr. ## as.network(modelstring(x),x) is the identity ## function. Beware though, that the output network needs to be ## learned so that the parameters are correct. ## first, split into nodes, assuming the correct form ## [node1|parent1:parent2][node2][node3|parent1] mstr <- x[1] score<- x[2] st <- strsplit(strsplit(mstr,"\\[")[[1]],"\\]") ## now, we have a list 2:nw$n+1 with all the nodes nw <- template for (i in 1:nw$n) { cn <- st[[i+1]] ## does this node have parents? cns <- strsplit(cn,"\\|")[[1]] if (length(cns)>1) { ## yes, parents are present parents <- cns[-1] parstr <- strsplit(parents,":")[[1]] pidx <- match(parstr,names(nw$nodes)) pidx <- pidx[!is.na(pidx)] nw$nodes[[i]]$parents <- sort(pidx) } else nw$nodes[[i]]$parents <- c() } nw$score <- as.numeric(score) nw } addarrow <- function(nw,df,prior,trylist=vector("list",size(nw))) { ## Create all networks with one extra arrow ## return list of networks (nwl) (Possibly NULL) ## trylist: a list of networks wherefrom some learning may be reused ## used by: autosearch ## uses: insert ## and network attributes: n nwl <- list() n <- nw$n try <- cbind(1:n,rep(1:n,rep(n,n))) for (i in 1:nrow(try)) { newnet <- insert(nw,try[i,1],try[i,2],df,prior, trylist=trylist) if ( !is.null(newnet$nw) ) { # prevent NULL networks nwl[length(nwl)+1] <- list(newnet$nw) trylist <- newnet$trylist } } class(nwl) <- "networkfamily" list(nw=nwl,trylist=trylist) } removearrow <- function(nw,df,prior,trylist=vector("list",size(nw))) { ## create all networks with one arrow less ## return list of networks (possibly NULL) ## trylist: a list of networks wherefrom some learning may be reused ## used by: autosearch ## uses: insert, learn ## and network attributes: n, nodes$parents nwl <- list() for (i in 1:nw$n) { if (length(nw$nodes[[i]]$parents) > 0) { for (j in 1:length(nw$nodes[[i]]$parents)) { newnet <- nw newnet$nodes[[i]]$parents <- newnet$nodes[[i]]$parents[-j] newnet <- learn(newnet,df,prior,i,trylist=trylist) trylist <- newnet$trylist newnet <- newnet$nw nwl[length(nwl)+1] <- list(newnet) } } } class(nwl) <- "networkfamily" list(nw=nwl,trylist=trylist) } turnarrow <- function(nw,df,prior,trylist=vector("list",size(nw))) { ## create all networks with one arrow turned ## return list of networks (possibly NULL) ## trylist: a list of networks wherefrom some learning may be reused ## used by: autosearch ## uses: insert, learn ## and network attributes: n, nodes$parents nwl <- list() for (i in 1:nw$n) { if (length(nw$nodes[[i]]$parents) > 0) { for (j in 1:length(nw$nodes[[i]]$parents)) { newnet <- nw parent <- nw$nodes[[i]]$parents[j] newnet$nodes[[i]]$parents <- newnet$nodes[[i]]$parents[-j] newnet <- learn(newnet,df,prior,i,trylist=trylist) trylist<- newnet$trylist newnet <- newnet$nw newnet <- insert(newnet,i,parent,df,prior,trylist=trylist) #parent is learned here trylist <- newnet$trylist newnet <- newnet$nw if (length(newnet) > 0) { # prevent NULL networks nwl[length(nwl)+1] <- list(newnet) } } } } class(nwl) <- "networkfamily" list(nw=nwl,trylist=trylist) } deal/R/addarrows.R0000644000175100001440000001353212101441102013475 0ustar hornikusers## addarrows.R ## Author : Claus Dethlefsen ## Created On : Fri Nov 02 21:02:07 2001 ## Last Modified By: Claus Dethlefsen ## Last Modified On: Mon Jan 12 14:45:43 2004 ## Update Count : 197 ## Status : Unknown, Use with caution! ############################################################################### ## ## Copyright (C) 2002 Susanne Gammelgaard Bøttcher, Claus Dethlefsen ## ## This program is free software; you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by ## the Free Software Foundation; either version 2 of the License, or ## (at your option) any later version. ## ## This program is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ## GNU General Public License for more details. ## ## You should have received a copy of the GNU General Public License ## along with this program; if not, write to the Free Software ## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ###################################################################### addarrows <- function(nw, node, data, prior,trylist=vector("list",size(nw))) { ## Create all possible networks with arrows to/from node from/to ## nodes with smaller index. ## ## data: dataframe ## prior: jointprior ## returns a list of networks (nwl) that have been learned ## trylist: a list of networks wherefrom some learning may be reused ## ## Used by: networkfamily ## Uses: insert nwl <- list(nw) # working network list for (i in 1:(node-1)) { for (j in 1:length(nwl)) { newnet <- insert(nwl[[j]],node,i,data,prior,trylist=trylist) if (length(newnet$nw) > 0 ) { # Prevent NULL networks nwl <- c(nwl, list(newnet$nw)) trylist <- newnet$trylist } newnet <- insert(nwl[[j]],i,node,data,prior,trylist=trylist) if (length(newnet$nw) > 0) { # Prevent NULL networks nwl <- c(nwl, list(newnet$nw)) trylist <- newnet$trylist } } } nwl <- nwl[-1] class(nwl) <- "networkfamily" list(nw=nwl,trylist=trylist) } insert <- function(nw,j,i,df,prior,nocalc=FALSE, trylist=vector("list",size(nw))) { ## insert one arrow from node j to node i in network nw ## df: dataframe ## prior: jointprior ## nocalc: if F, relearn the net; else do not relearn ## trylist: a list of networks wherefrom some learning may be reused ## If arrow is illegal, returns a NULL network. Otherwise, returns a ## network with the arrow added (and relearned, if nocalc=F) ## Used by: addarrows, drawnetwork, addarrow, turnarrow ## Uses: learn(.network) if nocalc=F ## network attributes: nodes[[]]$type, nodes[[]]$parents, ## nw$banlist, nodes[[]]$tvar ## examines if the arrow is legal (no continuous parents for discrete ## node), is not banned. if (i==j) { ## cat("Arrow (",i,"<-",j,") illegal\n") return(list(nw=NULL,trylist=trylist)) # RETURNS a NULL network } if (nw$nodes[[i]]$type=="discrete" & nw$nodes[[j]]$type=="continuous") { ## cat("Arrow (",i,"<-",j,") illegal\n") return(list(nw=NULL,trylist=trylist)) # RETURNS a NULL network } else if (!is.na(match(j,nw$nodes[[i]]$parents))) { ## cat("Arrow (",i,"<-",j,") already exists\n") return(list(nw=NULL,trylist=trylist)) # RETURNS a NULL network } else if (!is.na(match(i,nw$nodes[[j]]$parents))) { ## cat("Arrow (",j,"<-",i,") already exists\n") return(list(nw=NULL,trylist=trylist)) # RETURNS a NULL network } else if (!is.null(nw$banlist)) { if (nrow(nw$banlist)>0) { idx <- (1:nrow(nw$banlist))[nw$banlist[,1]==j] if (length(idx)>0) if (!is.na(match(i,nw$banlist[idx,2]))) { ## cat("Arrow (",j,"<-",i,") banned\n") return(list(nw=NULL,trylist=trylist)) # RETURNS a NULL network } } } ## update parents nw$nodes[[i]]$parents <- sort(c(nw$nodes[[i]]$parents,j)) if (!nocalc) { nw <- learn(nw,df,prior,i,trylist=trylist) trylist <- nw$trylist nw <- nw$nw } list(nw=nw,trylist=trylist) } remover <- function(nw,j,i,df,prior,nocalc=FALSE, trylist=vector("list",size(nw))) { ## remove one arrow from node j to node i in network nw ## df: dataframe ## prior: jointprior ## nocalc: if F, relearn the net; else do not relearn ## trylist: a list of networks wherefrom some learning may be reused ## Used by: drawnetwork ## Uses: learn(.network) if nocalc=F ## network attributes: nodes[[]]$parents if (i==j) { ## cat("Arrow (",i,"<-",j,") illegal\n") return(list(nw=NULL,trylist=trylist)) # RETURNS a NULL network } ## check if there *is* an arrow from i to j. parents <- nw$nodes[[i]]$parents if (!length(intersect(parents,j))>0) { cat("There's no arrow there!\n") return(list(nw=NULL,trylist=trylist)) # RETURNS a NULL network } else { ## update parents nw$nodes[[i]]$parents <- setdiff(nw$nodes[[i]]$parents,j) } if (!nocalc) { nw <- learn(nw,df,prior,i,trylist=trylist) trylist <- nw$trylist nw <- nw$nw } list(nw=nw,trylist=trylist) } deal/NAMESPACE0000644000175100001440000001120312101441102012373 0ustar hornikusers export("addarrow", "addarrows", "addrandomarrow", "as.network", "autosearch", "banlist", "banlist<-", "cond.node", "conditional", "conditional.cont", "conditional.disc", "cycletest", "deleterandomarrow", "drawnetwork", "elementin", "findex", "findleaf", "genlatex", "genpicfile", "getnetwork", "gettable", "gettrylist", "heuristic", "insert", "inspectprob", "jointcont", "jointdisc", "jointprior", "learn", "learnnode", "localmaster", "localposterior", "localprior", "localprob", "localprob<-", "makenw", "makesimprob", "maketrylist", "modelstring", "network", "networkfamily", "node", "nodes", "nodes<-", "numbermixed", "nwequal", "nwfsort", "perturb", "plot.network", "plot.networkfamily", "plot.node", "post", "post0", "postc", "postc0c", "postcc", "postdist", "postdist.node", "print.network", "print.networkfamily", "print.node", "printline", "prob", "prob.network", "prob.node", "readnet", "removearrow", "remover", "rnetwork", "savenet", "score", "score.network", "score.node", "size", "turnarrow", "turnrandomarrow", "udisclik", "unique.networkfamily") useDynLib(deal) #export( "newCoCoTestObject", # "label", "width", # "testEdge", "subModifyModel", "modifyModel", "dynamic.Graph") #exportClasses("CoCoTestClass") #exportMethods("label", "width", # "testEdge", "subModifyModel", "modifyModel", "dynamic.Graph", # "setGraphComponents", "graphComponents", "vertexEdges") #import(methods) #import(dynamicGraph) #S3method(terms,hllm) #S3method(terms,hllmloglm) #S3method(deviance,hllm) #S3method(deviance,hllmloglm) #S3method(extractAIC,hllm) #S3method(extractAIC,hllmloglm) #S3method(resid,hllmloglm) #S3method(fitted,hllmloglm) #export(#".Load.gRbase", #".Load.gRbase.hllm", #".Load.gRbase.hllmfit", #".Load.gRbase.hllmodify", #".Load.dynamicgraph", #".Load.gRbase.general", # "LabelAllEdges", # "dynamic.gR.Graph", # "gREdges", # "gRVariableDescription", # "UserMenus", # "all.subsets", # "selectOrder", # "extract.power", # "process.formula", # "subsetof", # "showg", # "readg", # "showf", # "readf", # "varset", # "in.list", # "is.cont", # "contains", # "remove.redundant", # "dual.rep", # "delete.edge", # "add.edge", # "is.graphical", # "validVarTypes" # ) #exportClasses("gmData", # "dataOrNULL", # "gModel", # "hllm", # "hllmTestClass", # "hllmengine", # "hllmloglin", # "hllmloglm" # ) #exportMethods("description", # "description<-", # "varTypes", # "varTypes<-", # "varNames", # "varNames<-", # "numberLevels", # "numberLevels<-", # "latent", # "latent<-", # "valueLabels", # "valueLabels<-", # "observations", # "observations<-", # "Formula", # "Formula<-", # "dropEdge", # "addEdge", # "dropVertex", # "addVertex", # "getFit", # "summary", # "fit", # "modifyModel", # "testEdge", # "label", # "width", # "dynamic.Graph", # "initialize", # "coerce", # "gmData" # ) deal/INDEX0000644000175100001440000000252712101441101011756 0ustar hornikusersautosearch Greedy search drawnetwork Graphical interface for editing networks genlatex From a network family, generate LaTeX output insert Insert/remove an arrow in network jointprior Calculates the joint prior distribution ksl Health and social characteristics learn Estimation of parameters in the local probability distributions makesimprob Make a suggestion for simulation probabilities maketrylist Creates the full trylist modelstring Tools for manipulating networks network Bayesian network data structure networkfamily Generates and learns all networks for a set of variables. node Representation of nodes numbermixed The number of possible networks nwfsort Sorts a list of networks perturb Perturbs a network prob Local probability distributions rats Weightloss of rats readnet Reads/saves .net file rnetwork Simulation of data sets with a given dependency structure score Network score unique.networkfamily Makes a network family unique. deal/DESCRIPTION0000644000175100001440000000154012101525636012704 0ustar hornikusersPackage: deal Version: 1.2-37 Date: 2013-01-28 Title: Learning Bayesian Networks with Mixed Variables Author: Susanne Gammelgaard Bottcher, Claus Dethlefsen. Maintainer: Claus Dethlefsen Depends: R (>= 2.0.0) Description: Bayesian networks with continuous and/or discrete variables can be learned and compared from data. License: GPL (>= 2) Collate: addarrows.R autosearch.R conditional.R cycletest.R drawnetwork.R findex.R generic.R genlatex.R heuristic.R inspectprob.R jointcont.R jointdisc.R jointprior.R learning.R makesimprob.R fullsimprob.R maketrylist.R master.R network.R networkfamily.R node.R numbermixed.R perturb.R postc.R postc0.R postdist.R readnet.R rnetwork.R savenet.R unique.R Packaged: 2013-01-28 09:17:55 UTC; 86c9 Repository: CRAN Date/Publication: 2013-01-28 17:47:26 deal/CHANGELOG0000644000175100001440000000075312101441101012375 0ustar hornikusers1.2-31: Changed a bug in jointprior thanks to Jean-Baptiste DENIS. A non-uniform prior would be multiplied together in a wrong fashion. 1.2-31: Changed a bug in autosearch and heuristic thanks to Peter van de Ven. The output network was not necessarily the one with highest loglikelihood due to a wrong sorting of the scores. 1.2-32: The bug in jointprior was reverted. Apparently not a bug and it would make the demo(ksl) go down. 1.2-34: Minor changes due to new R version