Nothing
## BIF: Interchange Format for Bayesian Networks
bif2char <- function(bstr) {
nc <- nchar(bstr)
if(substr(bstr,1,1)=="\"")
bstr <- substr(bstr,2,nc)
nc <- nc-1
if(substr(bstr,nc,nc)=="\"")
bstr <- substr(bstr,1,nc-1)
if(substr(bstr,nc-1,nc-1)=="\"")
bstr <- substr(bstr,1,nc-2)
return(bstr)
}
bif.parse.var <- function(strvar) {
nodename <- NA
strvar <- unlist(strsplit(strvar, split=" "))
nc <- which(strvar=="")
if(length(nc)>0)
strvar <- strvar[-nc]
if(strvar[1]!="variable")
return(NULL)
strvar <- strvar[-1]
tagnode <- bif2char(strvar[1])
strvar <- strvar[-1]
if(strvar[1] != "{" || strvar[length(strvar)] != "}")
return(NULL)
strvar <- strvar[-c(1, length(strvar))]
if(strvar[1] =="property" && strvar[2] == "label" && strvar[3] == "=") {
nodename <- bif2char(strvar[4])
strvar <- strvar[-c(1,2,3,4)]
if(length(strvar) < 1)
return(NULL)
}
while(length(strvar) > 0 && strvar[1] != "type")
strvar <- strvar[-1]
if(substr(strvar[2],1,8) != "discrete")
return(NULL)
while(strvar[1] != "{")
strvar <- strvar[-1]
if(strvar[1] != "{")
return(NULL)
strvar <- strvar[-1]
nc <- length(strvar)
if(nc<2)
return(NULL)
while(strvar[nc] != "}" && strvar[nc] != "};")
nc <- nc - 1
if(nc < 2)
return(NULL)
strvar <- strvar[1:(nc-1)]
for(i in 1:length(strvar)) {
nc <- nchar(strvar[i])
if(substr(strvar[i], nc,nc) == ",")
strvar[i] <- substr(strvar[i], 1,nc-1)
}
if(is.na(nodename))
nodename <- tagnode
return(list(tagnode, nodename, strvar))
}
cnCatnetFromBif <- function(file) {
lines <- tryCatch(readLines(file), error=function(e) NA, warning=function(e) NA)
nlines <- length(lines)
if(nlines<2) {
stop("cannot read ", file)
return(NULL)
}
nl <- 0
while(nl < nlines) {
nl <- nl+1
str <- unlist(strsplit(lines[nl], split=" "))
if(length(str) < 1)
next
while(str[1]=="") str <- str[-1]
if(str[1] == "network")
break
}
if(str[1] != "network")
stop("wrong format")
netname <- bif2char(str[2])
while(nl < nlines) {
str <- NULL
while(length(str) < 1 && nl < nlines) {
nl <- nl+1
str <- unlist(strsplit(lines[nl], split=" "))
}
while(str[1]=="") str <- str[-1]
if(str[1] == "}")
break
}
nodes <- NULL
cats <- NULL
nnodes <- 0
tagnodes <- NULL
while(nl < nlines) {
str <- NULL
while(length(str) < 1 && nl < nlines) {
nl <- nl+1
str <- unlist(strsplit(lines[nl], split=" "))
}
while(str[1]=="") str <- str[-1]
if(str[1] != "variable" && str[1] != "probability")
next
if(str[1] == "probability")
break
if(length(which(str == "{")) < 1)
stop("wrong format, line ", nl)
nstrend <- which(str == "//")
if(length(nstrend) == 1)
str <- str[1:(nstrend-1)]
strvar <- paste(str, collapse=" ")
while(1) {
str <- NULL
while(length(str) < 1 && nl < nlines) {
nl <- nl+1
str <- unlist(strsplit(lines[nl], split=" "))
}
while(str[1]=="") str <- str[-1]
nstrend <- which(str == "//")
if(length(nstrend) == 1)
str <- str[1:(nstrend-1)]
str <- paste(str, collapse=" ")
for(i in 1:(nchar(str)-1)){
if(substr(str, i, i+1) == "//") {
str <- substr(str, 1, i-1)
break
}
}
strvar <- paste(strvar, str, collapse=" ")
if(length(which(str == "}")) == 1)
break
}
node.var <- bif.parse.var(strvar)
if(is.null(node.var))
stop("wrong variable, line ", nl)
tagnodes <- c(tagnodes, node.var[[1]])
nodes <- c(nodes, node.var[[2]])
nnodes <- nnodes+1
newcats <- vector("list", nnodes)
if(nnodes > 1)
for(i in 1:(nnodes-1))
newcats[[i]] <- cats[[i]]
newcats[[nnodes]] <- node.var[[3]]
cats <- newcats
}
lpars <- vector("list", nnodes)
lprobs <- vector("list", nnodes)
while(nl < nlines) {
if(str[1] != "probability") {
str <- NULL
while(length(str) < 1 && nl < nlines) {
nl <- nl+1
str <- unlist(strsplit(lines[nl], split=" "))
}
while(str[1]=="") str <- str[-1]
next
}
strnode <- str[3]
nnode <- which(tagnodes==strnode)
if(length(nnode)!=1)
stop("wrong node ", strnode)
c1 <- which(str == "|")
c2 <- which(str == ")")
if(length(c2)==0)
c2 <- which(str == "){")
if(length(c1)!=1)
c1 <- c2
nodepars <- NULL
if(c1 < c2-1) {
for(cc in (c1+1):(c2-1)) {
spar <- str[cc]
if(substr(spar, nchar(spar),nchar(spar)) == ",")
spar <- substr(spar, 1,nchar(spar)-1)
if(substr(spar, 1,1) == ",")
spar <- substr(spar, 2,nchar(spar))
npar <- which(tagnodes==spar)
if(length(npar)==1)
nodepars <- c(nodepars, npar)
}
lpars[[nnode]] <- nodepars
}
nl <- nl + 1
k <- 0
while(nl+k < nlines) {
strend <- unlist(strsplit(lines[nl+k], split=" "))
while(strend[1]=="") strend <- strend[-1]
if(strend[1] == "property") {
nl <- nl+1
next
}
if(strend[1] == "}" || strend[1] == "};")
break
k <- k+1
}
nodeprobs <- vector("list", k)
k <- 1
while(nl < nlines) {
strend <- unlist(strsplit(lines[nl], split=" "))
while(strend[1]=="") strend <- strend[-1]
if(strend[1] == "}" || strend[1] == "};")
break
nodeprobs[[k]] <- unlist(strsplit(lines[nl], split=" "))
nl <- nl+1
k <- k+1
}
lprobs[[nnode]] <- nodeprobs
nl <- nl+1
if(nl >= nlines)
break
str <- unlist(strsplit(lines[nl], split=" "))
while(str[1]=="") str <- str[-1]
}
cn <- cnNew(nodes, cats, lpars)
cn@meta <- netname
for(i in 1:nnodes) {
nodecats <- cn@categories[[i]]
nodepars <- cn@parents[[i]]
if(length(nodepars)<1) {
str <- lprobs[[i]][[1]]
ns <- length(str)
nns <- 1
while(nns<ns) {
if(str[nns]=="table")
break
nns <- nns+1
}
nns <- nns+1
cprobs <- NULL
while(nns <= ns) {
snum <- str[nns]
if(substr(snum, nchar(snum),nchar(snum)) == "," || substr(snum, nchar(snum),nchar(snum)) == ";")
snum <- substr(snum, 1,nchar(snum)-1)
cprobs <- c(cprobs, as.numeric(snum))
nns <- nns+1
}
cn@probabilities[[i]] <- cprobs
next
}
## nodeparents > 0
probtable <- vector("list", length(lprobs[[i]]))
idtable <- 0
for(j in 1:length(lprobs[[i]])) {
str <- lprobs[[i]][[j]]
while(str[1]=="") str <- str[-1]
strcat <- paste(str[1:length(nodepars)], collapse="")
ns <- nchar(strcat)
if(substr(strcat, 1,1) != "(" || substr(strcat, ns,ns) != ")")
stop("wrong parents ", strcat)
strcat <- substr(strcat, 2, ns-1)
strcat <- unlist(strsplit(strcat, split=","))
parcats <- NULL
for(np in 1:length(nodepars)) {
cc <- strcat[np]
nc <- which(cn@categories[[nodepars[np]]] == cc)
if(length(nc) != 1)
stop("wrong parent categories ", cc)
parcats <- c(parcats, as.integer(nc))
}
nodeprobs <- NULL
for(nns in 1:length(nodecats)) {
while(str[length(nodepars)+nns]==",") str <- str[-c(length(nodepars)+nns)]
strprob <- str[length(nodepars)+nns]
ns <- nchar(strprob)
if(substr(strprob, ns,ns) == "," || substr(strprob, ns,ns) == ";")
strprob <- substr(strprob, 1,ns-1)
nodeprobs <- c(nodeprobs, as.numeric(strprob))
}
idtable <- idtable+1
probtable[[idtable]] <- nodeprobs
}
cn@probabilities[[i]] <- setNodeProbTable(i, nodepars, cn@categories, 1:length(nodepars), probtable, 1)
}
return(cn)
}
setNodeProbTable <- function(idroot, ppars, pcatlist, idx, probtable, idtable) {
if(is.null(ppars) || length(ppars) < 1 || length(idx) < 1) {
if(length(pcatlist[[idroot]]) < 1) {
return(NULL)
}
##cat(idtable, "\n")
return(as.vector(probtable[[idtable]]))
}
id <- ppars[idx[1]]
off <- 1
if(idx[1]>1)
for(ip in 1:(idx[1]-1))
off <- off*length(pcatlist[[ppars[ip]]])
##cat("pars ", nodepars[idx], ", ", off, "\n")
poutlist <- lapply(1:length(pcatlist[[id]]),
function(cat)
setNodeProbTable(idroot, ppars, pcatlist, idx[-1], probtable, idtable+off*(cat-1)))
return(poutlist)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.