## addarrows.R
## Author          : Claus Dethlefsen
## Created On      : Fri Nov 02 21:02:07 2001
## Last Modified By: Claus Dethlefsen
## Last Modified On: Tue Jul 22 11:35:12 2003
## Update Count    : 194
## 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
######################################################################


addarrows <- function(nw, node, data, prior,trylist=vector("list",nw$n)) {
    ## 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",nw$n)) {
    ## 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",nw$n)) {
    ## 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)
}
## autosearch.R
## Author          : Claus Dethlefsen
## Created On      : Fri Jan 11 10:54:00 2002
## Last Modified By: Claus Dethlefsen
## Last Modified On: Mon Aug 25 11:34:11 2003
## Update Count    : 296
## 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
######################################################################

autosearch <- function(initnw,data,prior=jointprior(network(data)),
                       maxiter=50,trylist= vector("list",initnw$n),
                       trace=TRUE,timetrace=TRUE,
                       showban=FALSE,saveall=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 <- modelstreng(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,modelstreng)))
        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," ",modelstreng(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")
        
    }
    
    tabel <- cbind(model,score)
    tabel <- tabel[sort.list(tabel[,2]),]
    list(nw=learn(nw,data,prior)$nw,tabel=tabel,trylist=trylist)
}

modelstreng <- 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(x,template) {
    ## x: vector of (modelstreng and score)
    ## from 'modelstreng' (output from modelstreng), 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(modelstreng(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",nw$n)) {
    ## 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",nw$n)) {
    ## 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",nw$n)) {
    ## 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)
}
## 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 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
######################################################################

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
}


## 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 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
######################################################################

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
}

## drawnetwork.R
## Author          : Claus Dethlefsen
## Created On      : Fri Nov 30 22:05:59 2001
## Last Modified By: Claus Dethlefsen
## Last Modified On: Tue Jul 22 15:58:25 2003
## Update Count    : 291
## 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
######################################################################


drawnetwork <- function(nw,
                        df,
                        prior,
                        trylist=vector("list",nw$n),
                        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)
}

## 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 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
######################################################################

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
}

## generic.R
## Author          : Claus Dethlefsen
## Created On      : Mon Nov 19 20:48:24 2001
## Last Modified By: Claus Dethlefsen
## Last Modified On: Thu Jul 24 14:08:32 2003
## Update Count    : 88
## 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
######################################################################



line <- function(s="-",n=60) cat(rep(s,n),"\n",sep="")

.First.lib <- function(lib, pkg)
{
    library.dynam("deal", package = pkg, lib.loc = lib)
    cat("\n")
    cat("-------------------------------------------------------------\n")
    cat(package.description("deal", lib = lib, field="Title"))
    cat("\n")
    ver <- package.description("deal", lib = lib, field="Version")
    maint<- package.description("deal", lib = lib, field="Maintainer")
    built<- package.description("deal", lib = lib, field="Built")
    URL  <- package.description("deal", lib = lib, field="URL")
    cat(paste("deal, version", ver,  "is now loaded\n"))
    cat("Copyright (C) 2002-2003, Susanne G. Bttcher and Claus Dethlefsen\n")
    cat("Maintained by",maint,"\n")
    cat("Webpage:",URL,"\n")
    cat("\nBuilt:",built,"\n")
    cat("-------------------------------------------------------------\n")
    cat("\n")
  return(invisible(0))
}

.Last.lib <- function(lib) {
  cat("Thank you for using Deal\n")
  return(invisible(0))
}

## genlatex.R --- 
## Author          : Claus Dethlefsen
## Created On      : Tue May 07 10:10:39 2002
## Last Modified By: Claus Dethlefsen
## Last Modified On: Mon Jul 28 10:41:22 2003
## Update Count    : 47
## 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
######################################################################

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")
}
## heuristic.R
## Author          : Claus Dethlefsen
## Created On      : Sun Jan 13 11:23:16 2002
## Last Modified By: Claus Dethlefsen
## Last Modified On: Mon Aug 25 11:30:45 2003
## Update Count    : 141
## 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
######################################################################

heuristic <-
  function(initnw,data,prior=jointprior(network(data)),
           maxiter=100,restart=10,degree=initnw$n,
           trylist= vector("list",initnw$n),trace=TRUE,
           timetrace=TRUE,saveall=FALSE,removecycles=FALSE)
{
    ## Heuristic search with random restart
    ## initnw: an initial network (already learned)
    ## data:   dataframe
    ## prior:  your favorite prior (has a default)
    ## maxiter:Max search steps in the search algorithm
    ## restart:The number of times to perturb initnw and rerun the search
    ## degree: Degree of perturbation
    ## trace=F: Do not plot
    
    ## outputs: The network with highest likelihood,
    ##          A list of start and end networks in the restart
    ##          A list of all networks tried 
    
    if (timetrace) {t1 <- proc.time();cat("[Heuristic ")}
    
    if (timetrace) s1 <- proc.time()[3]
    nwl <- autosearch(initnw,
                      data,prior,
                      maxiter,
                      trylist,
                      trace=trace,timetrace=TRUE,saveall=saveall,
                      removecycles=removecycles)
    
    nw <- nwl$nw
    trylist <- nwl$trylist
#    nwl <- nwfunique(nwfsort(nwl$nwl))
    tabel <- nwl$tabel
    
    if (timetrace) {
        s2 <- proc.time()[3]
        sauto <- s2-s1
        spert <- 0
        suniq <- 0
    }
    if (restart>0) {
        for (i in 1:restart) {
            if (timetrace) s3 <- proc.time()[3]
            nw <-
                perturb(initnw,data,prior,degree,trylist=trylist,timetrace=TRUE)
            trylist <- nw$trylist

            nw <- nw$nw
            ms <- modelstreng(nw)
            if (timetrace) {
                s4 <- proc.time()[3]
                spert <- spert + s4-s3
            }
            if (!is.na(match(ms,tabel[,1]))) next
#            if (elementin(nw,nwl)) next
            tabel <- rbind(tabel,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,saveall=saveall,removecycles=removecycles)
            trylist <- newnwl$trylist
#            newnwl <- newnwl$nwl
            tabel <- rbind(tabel,newnwl$tabel)
#            nw <- newnwl$nw
            if (timetrace) {
                s6 <- proc.time()[3]
                sauto <- sauto + s6-s5
            }
#            nwl <- c(nwl,newnwl)
            if (timetrace) s7 <- proc.time()[3]
#            nwl <- nwfunique(nwfsort(nwl),timetrace=FALSE,equi=FALSE)
            tabel <- tabel[!duplicated(tabel[,1]),]
            tabel <- tabel[sort.list(tabel[,2]),]
            if (timetrace) {
                s8 <- proc.time()[3]
                suniq <- suniq + s8 - s7
            }
        } ## for i
        ##    nwl <- nwfsort(nwl)
    } ## if restart
#    class(nwl) <- "networkfamily"
    if (initnw$n<15) antal <- paste(numbermixed(initnw$nc,initnw$nd))
    else antal <- "many"
    
    cat("Tried",nrow(tabel),"out of approx.",antal,"networks\n")
#    cat("Tried",length(nwl),"out of",antal,"networks\n")
    if (timetrace) {
        t2 <- proc.time()
        cat((t2-t1)[1],"]\n")
        cat("Perturb:",spert,",Autosearch:",sauto,",Unique:",suniq,"\n")
    }


    thebest <- as.network(tabel[1,],initnw)
    thebest <- learn(thebest,data,prior)$nw
    list(nw=thebest,tabel=tabel,trylist=trylist)
    #list(nw=nwl,trylist=trylist)
}
## inspectprob.R
## Author          : Claus Dethlefsen
## Created On      : Sun Feb 03 15:02:14 2002
## Last Modified By: Claus Dethlefsen
## Last Modified On: Tue Jul 22 16:38:27 2003
## Update Count    : 34
## 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
######################################################################

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")
        {
            line()
            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")
        {
            line()
            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
}

## 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 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
######################################################################

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

## jointdisc.R --- 
## Author          : Claus Dethlefsen
## Created On      : Wed Mar 06 12:52:57 2002
## Last Modified By: Claus Dethlefsen
## Last Modified On: Wed Jul 23 11:22:58 2003
## Update Count    : 28
## 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
######################################################################

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))
        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
  
## 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 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
######################################################################

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 (N<minN) {
   cat("Warning: Your choice of imaginary sample size is very low\n")
   cat("We advice you to set the imaginary sample size to more than",minN,"\n")
            }

        cat("Imaginary sample size:",N,"\n")
        jointalpha <- jointprob * N
        
        jointnu   <- jointalpha
        jointrho  <- jointalpha
    }
    else {  ## no discrete nodes
        jointnu   <- N
        jointrho  <- N
        jointalpha <- N
    }

    ## ##############################################
    ## Parameters for continuous variables
    ## ##############################################

    if (nw$nc>0) { ## 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)
}

## learning.R
## Author          : Claus Dethlefsen
## Created On      : Mon Jan 14 12:24:13 2002
## Last Modified By: Claus Dethlefsen
## Last Modified On: Wed Jul 23 11:37:33 2003
## Update Count    : 550
## 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
######################################################################

learn <- function(nw, df, prior=jointprior(nw),
                  nodelist=1:nw$n,trylist=
                  vector("list",nw$n),
                  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
}


## makesimprob.R
## Author          : Claus Dethlefsen
## Created On      : Tue Feb 26 13:25:44 2002
## Last Modified By: Claus Dethlefsen
## Last Modified On: Wed Jul 23 13:25:29 2003
## Update Count    : 143
## 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
######################################################################

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,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
}
## 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 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
######################################################################


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
}


## 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 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
######################################################################

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)
}



## network.R
## Author          : Claus Dethlefsen
## Created On      : Fri Nov 02 21:20:16 2001
## Last Modified By: Claus Dethlefsen
## Last Modified On: Mon Jul 28 10:05:38 2003
## Update Count    : 310
## 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
######################################################################

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.network(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,...)
            }
        }
    }
    
}

prob.network <- function(x,df) {
    ## calculate initial probability
    x$nodes <- lapply(x$nodes,prob.node,x,df)
    x
}


banlist <- function(x) { x$banlist }

"banlist<-" <- function(x,value) {x$banlist <- value;x}
## networkfamily.R
## Author          : Claus Dethlefsen
## Created On      : Tue Oct 30 16:43:05 2001
## Last Modified By: Claus Dethlefsen
## Last Modified On: Sun Jul 27 16:15:42 2003
## Update Count    : 427
## 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
######################################################################

networkfamily <- function(data,nw=network(data),prior=jointprior(nw),
                          trylist=vector("list",nw$n),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")
    line()
    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)
}

## node.R
## Author          : Claus Dethlefsen
## Created On      : Fri Nov 02 21:18:50 2001
## Last Modified By: Claus Dethlefsen
## Last Modified On: Mon Jul 28 11:01:58 2003
## Update Count    : 401
## Status          : OK
###############################################################################
##
##    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
######################################################################

nodes <- function(nw) nw$nodes
"nodes<-" <- function(nw,value) {nw$nodes<-value;nw}

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)   {
        line()
        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)   {
        line()
        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,nw,df) {
    
    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
}

## 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 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
######################################################################


numbermixed <- function(nd,nc) {
  ## number of mixed networks with nd discrete and nc continuous nodes
  ## (see Bttcher (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)
}

## perturb.ssc --- 
## Author          : Claus Dethlefsen
## Created On      : Sun Jan 13 10:16:01 2002
## Last Modified By: Claus Dethlefsen
## Last Modified On: Thu Jul 24 14:49:56 2003
## Update Count    : 100
## 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
######################################################################

perturb <- function(nw,data,prior,degree=nw$n,trylist=vector("list",nw$n),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",nw$n),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",nw$n),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",nw$n),nocalc=FALSE,timetrace=FALSE) {
  ## 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)
}

## postc.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:18:29 2003
## Update Count    : 143
## 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
######################################################################

postc <- function(mu,tau,rho,phi,y,z,timetrace=FALSE) {
    ## Posterior for continuous node with continuous parents
    ## written as a for-loop in R (slow)
    if (timetrace) {t1 <- proc.time();cat("[postc ")}
    
    
    loglik <- 0
    for (i in 1:length(y)) {

        ## likelihood
        logscale <- log(phi) + log( 1 + t(z[i,])%*%solve(tau)%*%z[i,])
        logk     <- lgamma( (rho+1)/2 ) - lgamma(rho/2) - 0.5*(logscale  +  log(pi)) 
        mscore   <- logk - 0.5*(rho+1)*log(1 + ((y[i] - z[i,]%*%mu)^2)/exp(logscale))

        loglik <- loglik + mscore

## update
        oldtau <- tau
        oldmu <- mu
        tau <- tau + z[i,]%*%t(z[i,])
        mu <- solve(tau)%*%(oldtau%*%mu+z[i,]*y[i])
        rho<- rho + 1
        phi<- phi + (y[i]-t(z[i,])%*%mu)*y[i] + t(oldmu-mu)%*%oldtau%*%oldmu
    }

  if (timetrace) {
    t2 <- proc.time()
    cat((t2-t1)[1],"]")
  }

    list(mu=mu,tau=tau,rho=rho,phi=phi,loglik=loglik)
}


post <- function(mu,tau,rho,phi,y,z,timetrace=FALSE) {
    ## Posterior for continuous node with continuous parents
    ## written as matrix notation in R
    if (timetrace) {t1 <- proc.time();cat("[post ")}
    
    mu.n  <- solve(tau+t(z)%*%z)%*%(tau%*%mu+t(z)%*%y)
    tau.n <- tau + t(z)%*%z
    rho.n <- rho + length(y)
    phi.n <- phi + t(y - z%*%mu.n)%*%y + t(mu - mu.n)%*%tau%*%mu

    loglik <- 0
    s <- as.numeric(phi)/rho*(diag(nrow(z))+ z%*%solve(tau)%*%t(z))
    k <- lgamma( (rho + length(y))/2 ) - lgamma(rho/2)-0.5*log(det(rho*s*pi))
    ind <- log( 1 + (mahalanobis(y,center=z%*%mu,cov=s,inverted=FALSE))/rho)
    loglik <- as.numeric(k) - (rho+length(y))/2 * ind

        
    if (timetrace) {
        t2 <- proc.time()
        cat((t2-t1)[1],"]")
    }

    list(mu=mu.n,tau=tau.n,rho=rho.n,phi=phi.n,loglik=loglik)
}

postM <- function(mu,tau,rho,phi,y,z,timetrace=FALSE) {
    ## Posterior for continuous node with continuous parents
    ## written as Matrix notation in R (needs Matrix)
    if (timetrace) {t1 <- proc.time();cat("[postM ")}
    
    z <- as.Matrix(z)
    mu.n  <- solve(as.Matrix(tau+t(z)%*%z))%*%(tau%*%mu+t(z)%*%y)
    tau.n <- tau + t(z)%*%z
    rho.n <- rho + length(y)
    phi.n <- phi + t(y - z%*%mu.n)%*%y + t(mu - mu.n)%*%tau%*%mu


    loglik <- 0
    s <- as.numeric(phi)/rho*(diag(nrow(z))+ z%*%solve(tau)%*%t(z))
    k <- lgamma( (rho + length(y))/2 ) - lgamma(rho/2)-0.5*log(det(rho*s*pi))
    ind <- log( 1 + (mahalanobis(y,center=z%*%mu,cov=s,inverted=FALSE))/rho)
    loglik <- as.numeric(k) - (rho+length(y))/2 * ind

        
    if (timetrace) {
        t2 <- proc.time()
        cat((t2-t1)[1],"]")
    }

    list(mu=mu.n,tau=tau.n,rho=rho.n,phi=phi.n,loglik=loglik)
}


postcc <- function(mu,tau,rho,phi,y,z,timetrace=FALSE) {
    ## Posterior for continuous node with x parents
    ## written as for-loop in C (fast)
    if (timetrace) {t1 <- proc.time();cat("[postcc ")}
    
    
    ## call to C
    res <- .C("postc",
              mu =as.double(c(mu)),
              tau=as.double(t(tau)),
              rho=as.double(rho),
              phi=as.double(phi),
              loglik=as.double(0),
              as.double(y),
              as.double(t(z)),
              as.integer(length(y)),
              as.integer(ncol(z)),
              PACKAGE="deal"
              )
    if (timetrace) {
        t2 <- proc.time()
        cat((t2-t1)[1],"]")
    }
    list(mu=res$mu,tau=matrix(res$tau,ncol(z),ncol(z)),rho=res$rho,phi=res$phi,loglik=res$loglik)
}
    
## 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 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
######################################################################


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)
}
    
## 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 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
######################################################################

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
}
readnet <- function(filename) {
    ## 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")
    l <- readLines(zz)
    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(zz)
    nw
}
## savenet.R --- 
## Author          : Claus Dethlefsen
## Created On      : Thu Sep 26 15:19:02 2002
## Last Modified By: Claus Dethlefsen
## Last Modified On: Mon Jul 28 10:41:46 2003
## Update Count    : 91
## 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
######################################################################

savenet <- function(nw,filename="default.net") {
    ## save network to .net file that can be read by eg. Hugin
    
    fn <- file(filename,"w")
    cat("%Created by deal,",date(),"\n",file=fn) # create empty file
    cat("%deal is Copyright (C) 2002-2003  Susanne Gammelgaard Bttcher, Claus Dethlefsen\n",file=fn)
    cat(rep("%",60),"\n\n",sep="",file=fn)
    ## ########################################
    ## Global information
    ## ########################################
    
    cat("net\n",file=fn)
    cat("{\n",file=fn)
    
    cat("\tnode_size = (40 40);\n",file=fn)
    
    cat("}\n\n",file=fn)
    
    ## ########################################
    ## DEFINE NODES
    ## ########################################
    for (i in 1:nw$n) { ## for each node
        nd <- nw$nodes[[i]]
        cat(
            nd$type,
            "node",
            nd$name,
            "\n",
            file=fn)
        cat("{\n",file=fn)
        if (nd$type=="discrete") {
            cat("\tstates = (",
                paste("\"",nd$levelnames,"\"",sep=""),
                ");\n",
                file=fn)
        }
        cat("\tlabel = \"", nd$name,"\";\n",sep="",file=fn)
        
        cat("\tposition = (",
            nd$position,
            ");\n",file=fn)
        
        
        cat("}\n\n",file=fn)
        
    }
    ## ########################################
    ## DEFINE POTENTIALS
    ## ########################################
    
    for (i in 1:nw$n) {
        nd <- nw$nodes[[i]]
        
        cat("\npotential (",
            nd$name, file=fn)
        
        if (length(nd$parents)>0) {
            cat(" | ",file=fn)
            ##            for (j in nd$parents)
            ##                cat(nw$nodes[[j]]$name," ",file=fn)
            ## apparently, discrete parents must appear before cont.
            for (j in intersect(nd$parents,nw$discrete))
                cat(nw$nodes[[j]]$name," ",file=fn)
            for (j in intersect(nd$parents,nw$continuous))
                cat(nw$nodes[[j]]$name," ",file=fn)
            
        }
        cat(" )\n",file=fn)
        
        cat("{\n",file=fn)
        
        ## # parameters defining local distribution

        ## ##################################################################
        ## discrete nodes
        ## ##################################################################
        if (nd$type=="discrete") {

            cat("\tdata=(",file=fn)
            
            
            ## the distribution of nd|parents in row-major layout
            if (length(nd$parents)>0) {

                cat("\n\t",file=fn)
                
                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 rkkeflge
                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=fn)
                    cat("\t%",lablist[i],"\n\t",file=fn)
                }
                
            }
            else { 
                cat(nd$prob,file=fn)
            }
            cat(");\n",file=fn)
            
            
        } # discrete
    
####################################################################
    ## continuous nodes
####################################################################
    if (nd$type=="continuous") {
        cat("\tdata=(\n\t",file=fn)
        
        
        ## skal skelne mellem kont. og disk. forldre
        ## hvis rene kont. forldre 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 rkkeflge
                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=fn)
                        
                        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=fn)
                                cat(nd$prob[i,j+2],"*",
                                    nw$nodes[[(intersect(nd$parents,nw$continuous))[j]]]$name,file=fn)
                            }
                        }
                        ## print remark in file with the config of disc.par.
                        cat(", ",nd$prob[i,1],")","\t%",lablist[i],"\n",file=fn)
                    }
                }
                else {
                    cat("normal ( ",nd$prob[2],file=fn)
                    
                    for (j in 1:(length(nd$prob)-2)) {
                        if (nd$prob[j+2]>=0)
                            cat("+",file=fn)                  
                        cat(nd$prob[j+2],"*",
                            nw$nodes[[(intersect(nd$parents,nw$continuous))[j]]]$name,file=fn)
                            }
                    cat(", ",nd$prob[1],")\n",file=fn)                    
                }
            }
            else {
                cat("normal ( ",nd$prob[2],", ",nd$prob[1],")\n",file=fn)
            }
            
            cat("\t);\n",file=fn)
        }
        
        cat("}\n",file=fn)
                
    }
    
    cat("File",filename,"created\n")
    close(fn)
    invisible()
}
## simulation.R
## Author          : Claus Dethlefsen
## Created On      : Tue Feb 26 11:22:30 2002
## Last Modified By: Claus Dethlefsen
## Last Modified On: Thu Jul 24 16:57:16 2003
## Update Count    : 418
## 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
######################################################################

simulation <- 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] <-
                node$levelnames[mymultinomial(n,node$simprob)] 
            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
}


## 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 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
######################################################################

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)
}


