# R/drawnetwork.R In deal: Learning Bayesian Networks with Mixed Variables

#### Documented in drawnetwork

## drawnetwork.R
## Author          : Claus Dethlefsen
## Created On      : Fri Nov 30 22:05:59 2001
## Update Count    : 292
## Status          : Unknown, Use with caution!
###############################################################################
##
##    Copyright (C) 2002  Susanne Gammelgaard Bottcher, Claus Dethlefsen
##
##    This program is free software; you can redistribute it and/or modify
##    the Free Software Foundation; either version 2 of the License, or
##    (at your option) any later version.
##
##    This program is distributed in the hope that it will be useful,
##    but WITHOUT ANY WARRANTY; without even the implied warranty of
##    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##    GNU General Public License for more details.
##
##    You should have received a copy of the GNU General Public License
##    along with this program; if not, write to the Free Software
##    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
######################################################################

drawnetwork <- function(nw,
df,
prior,
trylist=vector("list",size(nw)),
unitscale=20,
cexscale=8,
arrowlength=.25,
nocalc=FALSE,
yr=c(0,350),
xr=yr,
...)
{

## arguments are the similar as for plot.network.
## nocalc=T: don't calculate scores (for use with 'specifynetwork')

par(mfrow=c(1,1))
plot(nw,unitscale=unitscale,
cexscale=cexscale,arrowlength=arrowlength,
showban=TRUE,xr=xr,yr=yr,...)

xc <- mean(xr)
yc <- mean(yr)

points(xc,yc,cex=cexscale+4,pch=5)
text(xc,yc,"Stop")

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

bgrem <- "white"; fgrem <- "black";
}
if (mode=="Remove") {
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,
symbols(2*xc-buttonx,2*yc-buttony,
text(2*xc-buttonx,2*yc-buttony,"Remove",col=fgrem)

symbols(2*xc-buttonx,2*yc-2*buttony,
text(2*xc-buttonx,2*yc-2*buttony,"Ban",col=fgban)

symbols(2*xc-buttonx,2*yc-3*buttony,
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) {
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 (from==to) {
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))) {
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 <- -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)
}

## Try the deal package in your browser

Any scripts or data that you put into this service are public.

deal documentation built on Nov. 10, 2022, 5:30 p.m.