deal/0000755000176200001440000000000013362552313011162 5ustar liggesusersdeal/src/0000755000176200001440000000000013362526600011751 5ustar liggesusersdeal/src/matrix.c0000644000176200001440000001272313362526600013426 0ustar liggesusers/* -*- 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 Bttcher, 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/src/postc0.c0000644000176200001440000000474213362526600013334 0ustar liggesusers/* -*- 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 Bttcher, 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.c0000644000176200001440000001305013362526600013244 0ustar liggesusers/* -*- 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/init.c0000644000176200001440000000327513362526600013067 0ustar liggesusers/* -*- Mode: C -*- * init.c --- Registration of C functions * Author : Claus Dethlefsen * Created On : Fri Oct 16 16:44:35 2018 * Last Modified By: Claus Dethlefsen * Last Modified On: Fri Oct 16 16:44:35 2018 * Update Count : 1 * Status : Final */ /* ## ## Copyright (C) 2018 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 // for NULL #include /* .C calls */ extern void postc(void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void postc0(void *, void *, void *, void *, void *, void *, void *); static const R_CMethodDef CEntries[] = { {"postc", (DL_FUNC) &postc, 9}, {"postc0", (DL_FUNC) &postc0, 7}, {NULL, NULL, 0} }; void R_init_deal(DllInfo *dll) { R_registerRoutines(dll, CEntries, NULL, NULL, NULL); R_useDynamicSymbols(dll, FALSE); } deal/src/matrix.h0000644000176200001440000000346413362526600013435 0ustar liggesusers/* -*- 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 Bttcher, 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/NAMESPACE0000644000176200001440000001201113362374171012400 0ustar liggesusers 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) importFrom("grDevices", "dev.off", "pictex") importFrom("graphics", "arrows", "identify", "locator", "par", "plot", "points", "symbols", "text", "title") importFrom("stats", "coef", "lsfit", "mahalanobis", "resid", "rgamma", "rnorm", "runif", "var") importFrom("utils", "write.table") S3method(plot,network) S3method(plot,networkfamily) S3method(plot,node) S3method(print,network) S3method(print,networkfamily) S3method(print,node) S3method(prob,network) S3method(prob,node) S3method(score,node) S3method(score,network) S3method(unique,networkfamily) #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/demo/0000755000176200001440000000000013362367572012121 5ustar liggesusersdeal/demo/regression.R0000644000176200001440000000320513362367572014424 0ustar liggesusers## 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/simulation.R0000644000176200001440000000356013362367572014434 0ustar liggesusers ## 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/00Index0000644000176200001440000000030413362367572013250 0ustar liggesusersksl 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/demo/ksl.R0000644000176200001440000000174313362367572013042 0ustar liggesuserslibrary(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/rats.R0000644000176200001440000000574513362367572013230 0ustar liggesusers## 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/CHANGELOG0000644000176200001440000000075313362367572012414 0ustar liggesusers1.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 deal/data/0000755000176200001440000000000013362367572012106 5ustar liggesusersdeal/data/reinis.rda0000644000176200001440000000076413362367572014076 0ustar liggesusersNPSZ561Y0g v-Qh1@noٕTdҴwQZhvB¸^֋IT-FaΫ<-fE"=%:r#:-B,cn}ttլ\rEǏcLlQn^asS oYiCĈx+P<օ CC.`xIǖEKk͝˦ɋ~T>.ˇчA&T'ndeal/data/ksl.txt.gz0000644000176200001440000002001613362367572014056 0ustar liggesusersm\KuM8 AJ uԢܫ󰗗?_?|_?_D3j'!3-NKjgzogf~f Pud6¿ѧڿ.3yв$Kq_]{~OSsyϐI]a\[wo??w#{L].c6ؤ0LeL@ړ!Kߩ{,^(YVt^=ğ95Ya<Ѻx27ʠ;{tݛV &Yf`oY~hK-y,|{w *̈ߧ?_L0ml`/(5tVc6u4=6.M{={Gl`l[Uli3^1-Gs :H,- Ncޛsu[koe##B߸Tا,5 SFL oƔ=g6m($Xަ[HMjcCYi=he{GxxZgסf`ϿQj_r4a_^_ـ!Jgu&úy\ᇜ1='ndw'BˈoT< -d zhS1w|ьٸϿD=)FDK[;J/Yđ5'inK'x4j]f̶V nR3:ky4[ l?zygJV=ݹTImDЂgL\7ѫ7ah8ZH2XNAe\XWoѲ]9[:%cwUh/ 'Kݐ8E2ogbI[]PJpDCA]GS&WSzǝʸ¬AǪl^!шt@ټnv|7GE?26|_mu6j9 `"mHə *tgK; {MPIIh oلЮ|Yuɼʖsm& )1)H;;Lg{K뗠rŅs KX%e^Jخ) E<`(TI~ AéQS<'\o 2?K^,vEtz30W1K@t"&SD!CdHɠ6r72*5!`m bGnEFQ8b*\孢ҧXBch3&q|y:"pz EJڇ[Q.u,*Es Zm\3Wn^ǔɇ'@7;%$CЉ;$oxV+}4Sr{Zݧa5 Nc43N" +pEWbsj8 J _( 6!g5c+M[&d.;+rtF?@BR{>zRoC o ,8N AxfLul>`:)F!?)〬$\2]Sk8&v}3ukcp/^Alh=`nQ {PƘҴ! )BĐf+v]&3}~6A2yZg&=#lf֫uM WcgŹ]1]df+qafup(,R}c!eg"'mc D uK^81sݾ܋A߼b0~0NPX2ݗ$CCK$墇 $LƥؕBv@a# ۦȨx~R "DL`-j7P2 E^] [87kэ] so  t N4@dq)\vSFT?RSdU&Yʶ3M{.rNm^/VG;֖Ւ*TY*F }dq{`bERt\rqPP'dOӬC.$技\lr+C`gJ&8CO#Ag 7[7&2a,l%[(gҗE/r)_Pބ^(U\t%^lH65k&TZIA7DWoIa,so ldmY8Cee)M x7#o7LHz.@fw3b&] |Nw`SPfaJ娫pbr{-}B;*tVޑFPevoc#37`)3hmfعCܳoR5!OQ|)xM&pcp̃du$zcU' hBi3QqpZq YBʳY0A|ɽ#:ȿLz.NƷoO3$5$>XK8C0JgfNeg,N&;iBq|B]ӆVkx jn #fdG }Avh7)i_rFnm܈5r)zݱ-̟Y`Bν/.v4nFȶ)γd-|(GRq?laVgqLgD+y:U͑:/oϢ8,::d ".Njd&;y:8E!_z7R8ohг,=W5ki<8 XxIo4op(1-Zg 8ֿ`]`?3Kf:r_xnQb|b4$p(:jbWjC(8cs $7!x?Mӯi1J9,sn79 \8-``bw)a`eb;)]/P 5 pQJsx~s v槩g|Hgj3,;YLǚ3t' D;'̸QrҮs xgN5a3R>qO5fYvH# 'Dg Vը7$ .~!ϻom\zJ zVj{>t(3k&MXvrX-7E^#>!(:1Lyr{:TQ_1J|D$h|_7|Fy?6tPM -&ᔅy>pW.x{JdkcvbQdw^w25ɲ <~&efA{b]G? փq\D48bkgx"(_ t`‹ f[@A!gx+爽Tjm ܃lpG=1$ ce.Hq|"|q-fcnEHAB ^t:(u`Ӂ%r߃ E9HW~rz^|&:C >g vc8Я{'ltEVQxLYۭ ] p2&{zrčc0MpieY: .P9> ݱ]?SƓBf,4x c#h.1zC H0+(}o5i%2p@bu0A? Y +C 4Gm$wE6nk6s'l͈65G*:ܥrX@0SG@CGl~^?}8*x`pI=od=#R]Mgvp߉#d;,L/CC2PrxUN$!z*qO#n8,б] I(~bPT ƂߩG$l'߾Cfow؄)r/v%'q_׹=8Q"rFu3ub\:"=gCd5nu;2D`(fMšSk aegߪ"o>7/'9dH]ނ\AAA( sgHI@A\9_Y r.] @DW;ۄ:%hU8`LUmg8H`Ŧ6[vix0!V1v<}Qy^xypnmp~}P}84AO$>X41kf8g9ׁ\~nr}1֠b%mơV\k1xm2Nŀ-n0`z?9396 _bnB ŠKlG/J/~}2@-<mQL 6?ND6hGla,+ϐlD8̛ϰXuL3T= q68-8%x6>[q4>>ȁ}WƵa!8,Y2V8vbkKppFD=;1kq8)e-ah=u4%qqX.&nmb] עePہ6EL|]@<\ߠ^طUزق:v,>>.:oAtC)ؾzF3mSpPS9wnоM=FQÈExm c,!UQW_ }Cae%ּhv9']@^m<9;ǜ69yt%}sXUlc/A,_P^|6@}y 9Xh"r1aQJl8qrvzG!goo;z"oTr_F*am/"1WHv uى 6cƏk;2\?1>:zN1(8GD~󌵳N{6l1'Po Y X(qsx5>> w3WcgDc7q;y6g >Fc&"|¡l80FvbZOh10e2>TgW]e|~2evXc_[7#竇/n;S;L7s"rJ] þzQvb)uTlkkb{4ɮTD֟܈ov6gជpd8@[FX krYh S@0-pA^;@3C^ xN K !ʤup ąPd{8@ #xQh.@>!)FBEX pq^=GxX<7#lPlB`c49;'|'3R3[:'R0FB[8Di8!;O M<@؅~uчA@#]pQ،G=@.µp U3քW G?'Sؐ[K| ѿn]7Gy.{жy8@oX[ . 1!Lܾ;o$Hatex#@0\C!L~%D*.Nw5&0N|ж(x(SU!G ~f!8WhTBMqzOqg_nD;zߎcײPv󪡎e{f)5]3選bx:v yš۵(쟝!4 Uavm0zDa$Jm&,{̓D^7st?]٢) Y û.6|Wejlf8ynd;?ٵnW5p#1/KCj[`LN*m1<_/3o~t7|d.t2WC:6}n鞞шzl :t5h+=7޴>zM49Y+nw=hH4VN%ӫz}Z棥4O/7SӋ_t8Opm-pĎ/9kDG!s_h!ZWڌЍW,=%7Y9—|1;e5?u-D=5GkMԼ!;xzãu~J^}:4Bz?{E/6n .}jnӇٝJrqPT pq%th5ʟefRa_u;IE>]m0X/xzk73޻J߿mT ?t9 *ժ=y\̻u\η^|^/$/]^;h4O̘:/5}s|O_yQ]b:o\/K_Bf姦+7Q PKD'?NKL2y|~h`j 7H}v{0܅Z|ZUIm{ϸFJ,|MNZ$eʘ#MT6ƴbW{ RyB[j88uδxb5״"w=ѻs47RhۭM✨sBd}R;IyhCVdTm<:Qrj^ۦ+A|R|J%{݃]XXMyG%ۦҊES EW;L:*: ,ẉ9.-[Yp-J%FT{i|nߵ'/*O͹~wZKj?"6\<UC6j~ߧ¬Djn>\) nq{0skT۟s\ZQɺtcK$W]߉dzZqnOSe9?z1~"͢T{r+;:pF-ҵyIk+rYZ1VlfTlCþyCਰrgYH*m|SzQfq$b.{NqGO+O-KVXw=wQX[nZ:.wr[j)v.1 ;,p'm~4(e*yu@=64 STrl։Tsv OHnA͖mxj^vRZg0/~lp.5. x_-7Z,+6}e*xgM#5/Mp n:) A-EbcqQ%$ԍt~ݺavnJ&$C#NiIM:-T5Jyj\s0c:8eɃ;n6pAjŠAWxsNŕR#QsWJ5\MMVwyڲD4g*<;ojι-KMשUaCOgeu53N}Ztj~C2NC_ܕOlӿ}:ES)Sk~rjBa*U8%;賉+OÅը29<8xZ7ṙ|i&Th g5[LysJKUicPqʷ=T+sr|zeGqԜbPSRjoY]]QϻRw |#^N];2i'yG~|69xh&Y9,r0 4L=~iz6gm6Zx 6)FuQ[h Ҙ*/8eY~tφU:g¼z!x鐘V~'7nz:5myrowU|y<|ǚW!yxHK_XyK{uNHJjvwR(~Q!ϼog%͐'}YAM;NTr>vtc*劻jqT|x4=%}HiؽG?RJ𔸽,m_+'uᇙԲԢKr#պ7=N>T='uv*Fewspj]۴y.3g&=A%m*uK<ɘ9uڻY#݁t738.cyavSQӠ[e~J-['ЏJ,usõR=TmӊV*6ae7:a/GmDcΤ`|Vϥ%#cEj-S0xӚ~*/glX6$({Cc bEsy'޼M +vsw@W*BzMǬqxt~CbxD7\ݩQޑ_|hcp|©`j>_/5PUOPgj:=|V_[ ~~[1<i1<3V a>N-J8|:k>+sz ˆ;[g4̯ƥsHؔ0!3jEb g\s*`ҭN = l]ڂWQk >Tj]WSzxٝ{7SS}y[](՜6*?]vNj'zIIE~=\Kw~c28Z|*+hx=^pU*828e=Κ&eF17y[|nդE],;Evoy97G=ܲ?;K|/%Qίy~V݅zI=To@q2X /:l>?-Do-~Z,? oKjVE,w/g'a[1ÞR̫y5sAx6'$S.iO受e8e8ayR"dNԵ*_zˠP>t_RJ~1\F3+KX>ׇ{T?_=Z} <_rG +1~K0_uOm6qmڴi)gz~ED3^$4&mF8<$A; tMi'gS-B^4ኣً6gnSw.]NM1?ݮ@>[/4iokzŭO1*WyG{;Rjq \Th:%Kfj7퍂"M}sVU] ~ejqMPjj5K8\~,sly-D?_q ;J7nt'8C]590uǎ#mJ ߉c~[|cIMևl 6?,O}=Ugopq\5;(O{?PAд5j\So|3e; '\]+ uVS9;m,K>?~#<: i*{9۴UUӑ˵aI=K>\,FBE]ϩJSE}|AEx3\? gbu*evpieB?׼oy*7[(SYUrjH/ZQ%w7*Ԡxڴ~<~6|}Q2h܉!qȃŒm{7voWJ<{]]{1l?3c Oҧ`)g>Dbg)4[u[wp˳} [ϰ&A9غue1Ths[Uue}ɗ_kj gֶv׷ލ+qew KLUNE և_vV597/7Pqָ}G)aǩ3y:?6ע u #wzu2QT\'},p]n{-mՊJS^[zú]}3ټ=$bGѨ` 멵D5NJ˿/~fk\%I?sk;1G'?m|l8:ƥkF8\˒m@tt Gp tδ@ C/q$j٢ H_z":)K GZ3Q<,ecGR(8ut{Jϖ (5rt$3ԑhmṷzň/3cGtp, !\iŌ#\B﫵4=1d_bпߎf':d<7c83> zF?i_fGf|LZ]O#2󝜣f/,ef$r?yiF?Uh,iZ}zݽL7њ#2Hޫ#}C2~Òε|⫵-߱=ֹjƑoH07? GͅO~!8%G@tt[IF?W'"s= -13p!8z7o.2Z??WҢ#đg~é;VO_+"|A }J;Z+ē^\]#'$|OI>' $|O&ϡ Ћs("^46nԁ6fMogy`;ne^B (4*OmLH9Գ/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/numbermixed.R0000644000176200001440000000344413362415622014033 0ustar liggesusers## 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 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 ###################################################################### numbermixed <- function(nd,nc) { ## number of mixed networks with nd discrete and nc continuous nodes ## (see Bottcher (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/readnet.R0000644000176200001440000000754113362367572013152 0ustar liggesusersreadnet <- 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/network.R0000644000176200001440000001503513362415250013201 0ustar liggesusers## 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 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 ###################################################################### 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/fullsimprob.R0000644000176200001440000000517113362367572014063 0ustar liggesusers## 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/networkfamily.R0000644000176200001440000001261513362415254014410 0ustar liggesusers## 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 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 ###################################################################### 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/conditional.R0000644000176200001440000000770613362415042014020 0ustar liggesusers## 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 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 ###################################################################### 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/generic.R0000644000176200001440000000552513362367572013144 0ustar liggesusers## 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/makesimprob.R0000644000176200001440000001107213362415230014014 0ustar liggesusers## 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 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 ###################################################################### 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/rnetwork.R0000644000176200001440000002677513362415324013402 0ustar liggesusers## 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 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 ###################################################################### 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/jointcont.R0000644000176200001440000001720213362415204013514 0ustar liggesusers## 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 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 ###################################################################### 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/postc0.R0000644000176200001440000000527013362415305012721 0ustar liggesusers## 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 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 ###################################################################### 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/autosearch.R0000644000176200001440000002417013362415034013646 0ustar liggesusers## 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 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 ###################################################################### 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/node.R0000644000176200001440000003050313362415261012434 0ustar liggesusers## 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 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 ###################################################################### 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/jointprior.R0000644000176200001440000001237113362415216013711 0ustar liggesusers## 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 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 ###################################################################### 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/postdist.R0000644000176200001440000000531013362415312013353 0ustar liggesusers## 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 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 ###################################################################### 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/jointdisc.R0000644000176200001440000000642413362415211013475 0ustar liggesusers## 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 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 ###################################################################### 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/savenet.R0000644000176200001440000002773213362415664013175 0ustar liggesusers## 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 raekkefolge 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. foraeldre ## hvis rene kont. foraeldre 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 raekkefolge 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/learning.R0000644000176200001440000002625213362415223013312 0ustar liggesusers## 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 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 ###################################################################### 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/inspectprob.R0000644000176200001440000000743513362415176014054 0ustar liggesusers## 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 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 ###################################################################### 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/unique.R0000644000176200001440000000752513362415336013030 0ustar liggesusers## 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 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 ###################################################################### 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/addarrows.R0000644000176200001440000001353213362415023013474 0ustar liggesusers## 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 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 ###################################################################### 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/R/drawnetwork.R0000644000176200001440000002035713362415057014067 0ustar liggesusers## 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 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 ###################################################################### 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/findex.R0000644000176200001440000000531313362415072012765 0ustar liggesusers## 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 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 ###################################################################### 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/perturb.R0000644000176200001440000001453413362415272013202 0ustar liggesusers## 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 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 ###################################################################### 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/maketrylist.R0000644000176200001440000000313613362415236014063 0ustar liggesusers## 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 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 ###################################################################### 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/cycletest.R0000644000176200001440000000624113362415051013505 0ustar liggesusers## 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 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 ###################################################################### 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/master.R0000644000176200001440000001125313362415243013003 0ustar liggesusers## 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 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 ###################################################################### 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/genlatex.R0000644000176200001440000001427113362415154013323 0ustar liggesusers## 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 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 ###################################################################### 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/MD50000644000176200001440000000653713362552313011505 0ustar liggesusers7d3112227e41f20f1338fd21020ff2c3 *CHANGELOG e2d95443422b048c52b9d26fe309b868 *DESCRIPTION e3c9a3e7728ecbdbce15668facfe6ea8 *INDEX 33e06f9f1ea5566550352453a7ca7443 *NAMESPACE bf766ad9a6fd6b0260adee747d97f357 *R/addarrows.R 36f7878037bc97b714e9e8dc0cfb15a4 *R/autosearch.R ff03fc8f8a8b8761b24a38424ae8de49 *R/conditional.R b2e879e8fc738fd6e9c2a60b68d6b5d7 *R/cycletest.R 7f1984703260a401004dc87585ae1ded *R/drawnetwork.R 68791c809c8606c2c79b3a99c9ea8ff2 *R/findex.R d64640cd267dd14803d9653b76471271 *R/fullsimprob.R c437642302ab0d880e96e33415652be0 *R/generic.R 5ea9ae85fa9fea6bddcc8f531c455672 *R/genlatex.R 11f58a49c81976636acef36a6a1964a7 *R/heuristic.R 44eb68c84fcc7bc014da8e92f6f3f664 *R/inspectprob.R 89e735c862e00e4c430b61600b911f6a *R/jointcont.R b62a08359d10292b1a9bf540637fc897 *R/jointdisc.R 2b905c319187d4d78568d6e1e755fc82 *R/jointprior.R 9909ecd37504bedad32f9b206be90c5d *R/learning.R 3c3f2a14eeaa002ffe22fc58c455d564 *R/makesimprob.R ebfb6527d708818ec0696596e6b18436 *R/maketrylist.R ce8069b570b4fb1bb27ff6936ee287b3 *R/master.R 306f526bb1c735ae7d0ba6147c933734 *R/network.R b6b2d4f52d3daa3580628f76e4d810ab *R/networkfamily.R 9785f65a1f2d005df1df2d0c4da5e8fa *R/node.R 06901957c54afb5e52eb98f40902b901 *R/numbermixed.R d0080ede75ff980c5d63454cb5df7bdb *R/perturb.R 786d7f0b08a6e2e418ea5c90caa1c382 *R/postc.R 5bdc187c9cba82ca41dd03cac9ddfe5e *R/postc0.R 554056870857905d4034a98aa85aea42 *R/postdist.R 4d64f30546067cef8d959c2a0db0d45f *R/readnet.R be12cbe97d59896daa36bce56722de6c *R/rnetwork.R ac4aad0f6cbd0cb1782b9e6327616e1f *R/savenet.R cb7b1eb76429f8c5ff6b2885d828371f *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 408c4b657d714ed4c8f3ae2dd4248c75 *man/autosearch.Rd adb6483f5fef98844c743d956e52e730 *man/deal-internal.Rd b02a0922f6e7448d3e6363b9ce4e354f *man/drawnetwork.Rd 6716def09547242dfc372ea9b5601a70 *man/genlatex.Rd e8c7809846dd863cb7160e7f447da02b *man/insert.Rd d6ea67ca035ecdf77e8223259132e48a *man/jointprior.Rd 1aea70528f6836db1f82874c07ff74c9 *man/ksl.Rd c58d8a8cbe3d708b600cc27e99a8c4d7 *man/learn.Rd 14a65294f934448294e5694d7f99d958 *man/makesimprob.Rd 6bd9aad0686eb96397686e2b3deb3350 *man/maketrylist.Rd cdaa4795f50a0123fa3c43d197f07ca2 *man/network.Rd 301ad51214143014eee11253eaeb2cdd *man/networkfamily.Rd 54bbd79c1186af92c7c83753cf58e668 *man/networktools.Rd f2cbd87ccf130feed0f58877712ef962 *man/node.Rd 388eb06976de3e0000b8270a4cf87eeb *man/numbermixed.Rd cff876dcb1ce9dccfe85e1b37c935053 *man/nwfsort.Rd 4f5ddcbc7c2f7d242f39776a3771cb20 *man/nwfunique.Rd 1c9d1ef6ee8e4f32603a15a5436403a8 *man/perturb.Rd 4961c3288181ae94f1f20574085d4207 *man/prob.Rd 8e1d6faded4f79a086c1722d080b8536 *man/rats.Rd 0fbe19a8762fc83241ccbe254277d4a2 *man/readnet.Rd b2d5e98dd928562fc8c67ae058b9de8f *man/rnetwork.Rd e1173a5eeda18952744c9706a1461d69 *man/score.Rd 4f255d3ea3963e33875cc9da1425f6ca *src/init.c 0e21cb62dab4280cfe0e917edcddca3b *src/matrix.c 7e80aef25b56e71290ce8dd9aa52ea16 *src/matrix.h 61bd062946606b0c2a2b6246cd4fc8f7 *src/postc.c ed6849b9711b1f4205bd9943834ba5c9 *src/postc0.c deal/DESCRIPTION0000644000176200001440000000173613362552313012677 0ustar liggesusersPackage: deal Version: 1.2-39 Date: 2018-10-20 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. The method is described in Boettcher and Dethlefsen (2003), . 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 NeedsCompilation: yes Packaged: 2018-10-20 04:22:24 UTC; clausdethlefsen Repository: CRAN Date/Publication: 2018-10-20 07:10:03 UTC deal/man/0000755000176200001440000000000013362414725011741 5ustar liggesusersdeal/man/networktools.Rd0000644000176200001440000000404613362367572015015 0ustar liggesusers% -*- 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/rats.Rd0000644000176200001440000000215113362412153013171 0ustar liggesusers% -*- 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. } \keyword{datasets} deal/man/score.Rd0000644000176200001440000000251613362412407013342 0ustar liggesusers% -*- 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, \cr Claus Dethlefsen \email{rpackage.deal@gmail.com}. } %\note{ ~~further notes~~ } % ~Make other sections like WARNING with \section{WARNING }{....} ~ \keyword{models} deal/man/ksl.Rd0000644000176200001440000000133113362412344013012 0ustar liggesusers \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)} } } \keyword{datasets} deal/man/nwfunique.Rd0000644000176200001440000000346113362412110014237 0ustar liggesusers% -*- 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)} } % \references{ % Further information about \bold{deal} can be found at:\cr % \url{http://www.math.aau.dk/~dethlef/novo/deal}. % } \author{ Susanne Gammelgaard Bottcher, \cr Claus Dethlefsen \email{rpackage.deal@gmail.com}. } %\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/drawnetwork.Rd0000644000176200001440000000702613362411431014573 0ustar liggesusers% -*- 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, \cr Claus Dethlefsen \email{rpackage.deal@gmail.com}. } \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/prob.Rd0000644000176200001440000000630213362412142013162 0ustar liggesusers% -*- 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, \cr Claus Dethlefsen \email{rpackage.deal@gmail.com}. } %\note{ ~~further notes~~ } % ~Make other sections like WARNING with \section{WARNING }{....} ~ \keyword{models} deal/man/jointprior.Rd0000644000176200001440000001152613362414725014434 0ustar liggesusers% -*- 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. } \author{ Susanne Gammelgaard Bottcher, \cr Claus Dethlefsen \email{rpackage.deal@gmail.com}. } %\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/makesimprob.Rd0000644000176200001440000000574613362411700014543 0ustar liggesusers% -*- 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}.} \seealso{\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, \cr Claus Dethlefsen \email{rpackage.deal@gmail.com}. } %\note{ ~~further notes~~ } % ~Make other sections like WARNING with \section{WARNING }{....} ~ \keyword{models} deal/man/maketrylist.Rd0000644000176200001440000000534713362411715014605 0ustar liggesusers% -*- 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, \cr Claus Dethlefsen \email{rpackage.deal@gmail.com}. } \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/autosearch.Rd0000644000176200001440000001175713362411363014374 0ustar liggesusers% -*- 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, \cr Claus Dethlefsen \email{rpackage.deal@gmail.com}. } %\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/man/numbermixed.Rd0000644000176200001440000000334613362414673014557 0ustar liggesusers% -*- 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. Aalborg University, 2003. Robinson, R.W. (1977). Counting unlabeled acyclic digraphs, Lecture Notes in Mathematics, 622: Combinatorial Mathematics. } \author{ Susanne Gammelgaard Bottcher, \cr Claus Dethlefsen \email{rpackage.deal@gmail.com}. } %\note{ ~~further notes~~ } % ~Make other sections like WARNING with \section{WARNING }{....} ~ \examples{ numbermixed(2,2) \dontrun{numbermixed(5,10)} } \keyword{models} deal/man/deal-internal.Rd0000644000176200001440000000657313362411414014752 0ustar liggesusers% -*- 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,...) } % \references{ % Further information about \bold{deal} can be found at:\cr % \url{http://www.math.aau.dk/~dethlef/novo/deal}. % } \author{ Susanne Gammelgaard Bottcher, \cr Claus Dethlefsen \email{rpackage.deal@gmail.com}. } \keyword{internal} deal/man/network.Rd0000644000176200001440000001245613362411741013724 0ustar liggesusers% -*- 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, \cr Claus Dethlefsen \email{rpackage.deal@gmail.com}. } %\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/nwfsort.Rd0000644000176200001440000000222513362412073013725 0ustar liggesusers% -*- 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}.} } % \references{ % Further information about \bold{deal} can be found at:\cr % \url{http://www.math.aau.dk/~dethlef/novo/deal}. % } \author{ Susanne Gammelgaard Bottcher, \cr Claus Dethlefsen \email{rpackage.deal@gmail.com}. } \keyword{iplot} deal/man/insert.Rd0000644000176200001440000000560213362411471013532 0ustar liggesusers% -*- 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, \cr Claus Dethlefsen \email{rpackage.deal@gmail.com}. } %\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/networkfamily.Rd0000644000176200001440000000761313362411755015132 0ustar liggesusers% -*- 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! } % \references{ % Further information about \bold{deal} can be found at:\cr % \url{http://www.math.aau.dk/~dethlef/novo/deal}. % } \author{ Susanne Gammelgaard Bottcher, \cr Claus Dethlefsen \email{rpackage.deal@gmail.com}. } \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/node.Rd0000644000176200001440000001406513362412006013151 0ustar liggesusers% -*- 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, \cr Claus Dethlefsen \email{rpackage.deal@gmail.com}. } %\note{ ~~further notes~~ } % ~Make other sections like WARNING with \section{WARNING }{....} ~ \keyword{models} deal/man/genlatex.Rd0000644000176200001440000000665613362411453014047 0ustar liggesusers% -*- 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}}} % \references{ % Further information about \bold{deal} can be found at:\cr % \url{http://www.math.aau.dk/~dethlef/novo/deal}. % } \author{ Susanne Gammelgaard Bottcher, \cr Claus Dethlefsen \email{rpackage.deal@gmail.com}. } %\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/learn.Rd0000644000176200001440000001066513362411623013333 0ustar liggesusers% -*- 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. } \author{ Susanne Gammelgaard Bottcher, \cr Claus Dethlefsen \email{rpackage.deal@gmail.com}. } \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/perturb.Rd0000644000176200001440000000534413362412121013705 0ustar liggesusers% -*- 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, \cr Claus Dethlefsen \email{rpackage.deal@gmail.com}. } %\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/rnetwork.Rd0000644000176200001440000000424013362412375014102 0ustar liggesusers% -*- 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, \cr Claus Dethlefsen \email{rpackage.deal@gmail.com}. } %\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.Rd0000644000176200001440000000337613362414634013662 0ustar liggesusers\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 used by Hugin. } \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. } % \references{ % Further information about \bold{deal} can be found at:\cr % \url{http://www.math.aau.dk/~dethlef/novo/deal}. % } \author{ Susanne Gammelgaard Bottcher, \cr Claus Dethlefsen \email{rpackage.deal@gmail.com}. } \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/INDEX0000644000176200001440000000252713362367572011775 0ustar liggesusersautosearch 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.