Nothing
R/foreign-write.R
In bnlearn: Bayesian Network Structure Learning, Parameter Learning and Inference
Defines functions
write.dot.backend
dsc.write.probabilities
dsc.write.node
net.write.probabilities
net.write.node
bif.write.probabilities
bif.write.node
sanitize.levels
write.foreign.backend
# dump a bn.fit object into a BIF/DSC/NET file.
write.foreign.backend = function(fd, fitted, format = "bif") {
# print the preamble.
if (format == "dsc")
cat("belief network \"unknown\"\n", file = fd)
if (format == "net")
cat("net \n{ \n}\n", file = fd)
else if (format == "bif")
cat("network unknown {\n}\n", file = fd)
# get the levels and the parents of each node.
levels = sapply(names(fitted), function(x) dimnames(fitted[[x]]$prob)[[1]],
simplify = FALSE)
levels = sanitize.levels(levels)
parents = lapply(fitted, "[[", "parents")
# print the variable decalarations, describing the number and the labels of
# the levels of eah node.
for (node in names(fitted)) {
if (format == "dsc")
dsc.write.node(node = node, levels = levels[[node]], fd = fd)
else if (format == "net")
net.write.node(node = node, levels = levels[[node]], fd = fd)
else if (format == "bif")
bif.write.node(node = node, levels = levels[[node]], fd = fd)
}#FOR
# print the (conditional) probbability table of each node.
for (node in names(fitted)) {
cpt = fitted[[node]]$prob
nlevels = length(levels[[node]])
if (format == "dsc")
dsc.write.probabilities(node = node, nlevels = nlevels, cpt = cpt,
parents = parents[[node]], fd = fd)
else if (format == "net")
net.write.probabilities(node = node, nlevels = nlevels, cpt = cpt,
parents = parents[[node]], fd = fd)
else if (format == "bif")
bif.write.probabilities(node = node, nlevels = nlevels, cpt = cpt,
parents = parents[[node]], fd = fd)
}#FOR
}#WRITE.BIF.BACKEND
sanitize.levels = function(levels) {
clean = lapply(levels, gsub, pattern = "[,{}()#%]", replacement = "_")
# preserve names, which is useful when the input comes from dimnames().
names(clean) = names(levels)
if (any(sapply(clean, anyDuplicated) > 0))
stop("duplicated levels after sanitization.")
return(clean)
}#SANITIZE.LEVELS
bif.write.node = function(node, levels, fd) {
cat("variable", node, "{\n type discrete [", length(levels),
"] {", paste(levels, collapse = ", "),
"};\n}\n", file = fd)
}#BIF.WRITE.NODE
bif.write.probabilities = function(node, nlevels, cpt, parents, fd) {
if (length(parents) == 0) {
probs = paste(format(cpt, nsmall = 1), collapse = ", ")
cat("probability (", node, ") {\n", file = fd)
cat(" table", paste(probs, ";\n", sep = ""), file = fd)
cat("}\n", file = fd)
}#THEN
else {
configs = sanitize.levels(dimnames(cpt)[-1])
configs = expand.grid(configs, stringsAsFactors = FALSE)
configs = apply(configs, 1, function(x) paste("(",
paste(x, collapse = ", "), ")", sep = "") )
cat("probability (", node, "|", paste(parents, collapse = ", "),
") {\n", file = fd)
for (i in seq_along(configs)) {
probs = cpt[nlevels * (i - 1) + seq(nlevels)]
# paper over missing values with a uniform distribution
if (all(is.na(probs)))
probs = rep(1, length(probs))/length(probs)
probs = paste(format(probs, nsmall = 1), collapse = ", ")
cat(" ", configs[i], paste(probs, ";\n", sep = ""), file = fd)
}#FOR
cat("}\n", file = fd)
}#THEN
}#BIF.WRITE.PROBABILITIES
net.write.node = function(node, levels, fd) {
cat("node", node, "\n{\n states = (", paste("\"", paste(levels,
collapse = "\" \""), "\"", sep = ""), ");\n}\n", file = fd)
}#NET.WRITE.NODE
net.write.probabilities = function(node, nlevels, cpt, parents, fd) {
if (length(parents) == 0) {
probs = paste(format(cpt, nsmall = 1))
cat("potential (", node, ") \n{\n", file = fd)
cat(" data = (", probs, ");\n}\n", file = fd)
}#THEN
else {
cat("potential (", node, "|", paste(parents, collapse = " "),
") \n{\n data = ", file = fd)
# in NET files the "most significant" variable for the ordering is the
# last one, not the first one.
configs = sanitize.levels(dimnames(cpt))
configs = expand.grid(configs[1+rev(1:length(parents))])
configs = configs[rev(1:ncol(configs))]
indexes = configurations(configs, factor = FALSE)
# paste CPT columns together and save them in the right order.
probs = character(length(indexes))
for (i in seq_along(indexes)) {
temp.probs = cpt[nlevels * (indexes[i] - 1) + seq(nlevels)]
# paper over missing values with a uniform distribution
if (all(is.na(temp.probs)))
temp.probs = rep(1, length(temp.probs))/length(temp.probs)
probs[i] = paste(format(temp.probs, nsmall = 1), collapse = " ")
probs[i] = paste("(", probs[i], ")", sep = "")
}#FOR
# add braces in the proper places.
parents.nlevels = dim(cpt)[-1]
for (i in rev(parents.nlevels)) {
blocks = (i - 1 + seq_along(probs)) %/% i
blocks = lapply(seq(max(blocks)), function(x) probs[blocks == x])
probs = sapply(blocks, function(x) paste("(", paste(x, collapse = ""), ")",
sep = "", collapse = ""))
}#FOR
cat(probs, ";\n}\n", file = fd)
}#ELSE
}#NET.WRITE.PROBABILITIES
dsc.write.node = function(node, levels, fd) {
cat("node", node, "{\n type : discrete [", length(levels),
"] = {", paste("\"", paste(levels, collapse = "\", \""), "\"", sep = ""),
"};\n}\n", file = fd)
}#DSC.WRITE.NODE
dsc.write.probabilities = function(node, nlevels, cpt, parents, fd) {
if (length(parents) == 0) {
probs = paste(format(cpt, nsmall = 1), collapse = ", ")
cat("probability (", node, ") {\n", file = fd)
cat(" ", paste(probs, ";\n", sep = ""), file = fd)
cat("}\n", file = fd)
}#THEN
else {
configs = expand.grid(lapply(dim(cpt)[-1], function(x) seq(x) - 1), stringsAsFactors = FALSE)
configs = apply(configs, 1, function(x) paste("(", paste(x, collapse = ", "), ")", sep = "") )
cat("probability (", node, "|", paste(parents, collapse = ", "),
") {\n", file = fd)
for (i in seq_along(configs)) {
probs = cpt[nlevels * (i - 1) + seq(nlevels)]
# paper over missing values with a uniform distribution
if (all(is.na(probs)))
probs = rep(1, length(probs))/length(probs)
probs = paste(format(probs, nsmall = 1), collapse = ", ")
cat(" ", configs[i], ":", paste(probs, ";\n", sep = ""), file = fd)
}#FOR
cat("}\n", file = fd)
}#ELSE
}#DSC.WRITE.PROBABILITIES
# export graph structures as DOT files.
write.dot.backend = function(fd, graph) {
if (is(graph, "bn"))
arcs = graph$arcs
else
arcs = fit2arcs(graph)
nodes = .nodes(graph)
if (nrow(arcs) == 0) {
# this is an empty graph, we assume it's (partially) directed.
cat("digraph {\n", file = fd)
cat(paste(' "', nodes(graph), '" ;'), sep = "\n")
cat("}\n", file = fd)
}#THEN
else {
wund = which.undirected(arcs, nodes)
type = ifelse(how.many(wund) == nrow(arcs), "graph", "digraph")
if (type == "graph") {
dedup = match(arcs[, "from"], nodes) < match(arcs[, "to"], nodes)
und = apply(arcs[wund & dedup, , drop = FALSE], 1,
function(x) paste('"', x, '"', sep = "", collapse = " -- "))
# this is an undirected graph.
cat("graph {\n", file = fd)
cat(paste(' "', nodes(graph), '" ;', sep = ""), sep = "\n", file = fd)
cat(paste(" edge [dir=none]", und, ";\n"), sep = "", file = fd)
cat("}\n", file = fd)
}#THEN
else if (type == "digraph") {
# this is a (partially) directed graph.
cat("digraph {\n", file = fd)
dir = apply(arcs[!wund, , drop = FALSE], 1,
function(x) paste('"', x, '"', sep = "", collapse = " -> "))
cat(paste(' "', nodes(graph), '" ;', sep = ""), sep = "\n", file = fd)
if (any(wund)) {
dedup = match(arcs[, "from"], nodes) < match(arcs[, "to"], nodes)
und = apply(arcs[wund & dedup, , drop = FALSE], 1,
function(x) paste('"', x, '"', sep = "", collapse = " -> "))
cat(paste(" edge [dir=none]", und, ";\n"), sep = "", file = fd)
}#THEN
cat(paste(" edge [dir=forward]", dir, ";\n"), sep = "", file = fd)
cat("}\n", file = fd)
}#ELSE
}#ELSE
}#WRITE.DOT.BACKEND
Try the bnlearn package in your browser
Any scripts or data that you put into this service are public.
bnlearn documentation built on Sept. 8, 2023, 5:46 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions write.dot.backend dsc.write.probabilities dsc.write.node net.write.probabilities net.write.node bif.write.probabilities bif.write.node sanitize.levels write.foreign.backend
# dump a bn.fit object into a BIF/DSC/NET file.
write.foreign.backend = function(fd, fitted, format = "bif") {
# print the preamble.
if (format == "dsc")
cat("belief network \"unknown\"\n", file = fd)
if (format == "net")
cat("net \n{ \n}\n", file = fd)
else if (format == "bif")
cat("network unknown {\n}\n", file = fd)
# get the levels and the parents of each node.
levels = sapply(names(fitted), function(x) dimnames(fitted[[x]]$prob)[[1]],
simplify = FALSE)
levels = sanitize.levels(levels)
parents = lapply(fitted, "[[", "parents")
# print the variable decalarations, describing the number and the labels of
# the levels of eah node.
for (node in names(fitted)) {
if (format == "dsc")
dsc.write.node(node = node, levels = levels[[node]], fd = fd)
else if (format == "net")
net.write.node(node = node, levels = levels[[node]], fd = fd)
else if (format == "bif")
bif.write.node(node = node, levels = levels[[node]], fd = fd)
}#FOR
# print the (conditional) probbability table of each node.
for (node in names(fitted)) {
cpt = fitted[[node]]$prob
nlevels = length(levels[[node]])
if (format == "dsc")
dsc.write.probabilities(node = node, nlevels = nlevels, cpt = cpt,
parents = parents[[node]], fd = fd)
else if (format == "net")
net.write.probabilities(node = node, nlevels = nlevels, cpt = cpt,
parents = parents[[node]], fd = fd)
else if (format == "bif")
bif.write.probabilities(node = node, nlevels = nlevels, cpt = cpt,
parents = parents[[node]], fd = fd)
}#FOR
}#WRITE.BIF.BACKEND
sanitize.levels = function(levels) {
clean = lapply(levels, gsub, pattern = "[,{}()#%]", replacement = "_")
# preserve names, which is useful when the input comes from dimnames().
names(clean) = names(levels)
if (any(sapply(clean, anyDuplicated) > 0))
stop("duplicated levels after sanitization.")
return(clean)
}#SANITIZE.LEVELS
bif.write.node = function(node, levels, fd) {
cat("variable", node, "{\n type discrete [", length(levels),
"] {", paste(levels, collapse = ", "),
"};\n}\n", file = fd)
}#BIF.WRITE.NODE
bif.write.probabilities = function(node, nlevels, cpt, parents, fd) {
if (length(parents) == 0) {
probs = paste(format(cpt, nsmall = 1), collapse = ", ")
cat("probability (", node, ") {\n", file = fd)
cat(" table", paste(probs, ";\n", sep = ""), file = fd)
cat("}\n", file = fd)
}#THEN
else {
configs = sanitize.levels(dimnames(cpt)[-1])
configs = expand.grid(configs, stringsAsFactors = FALSE)
configs = apply(configs, 1, function(x) paste("(",
paste(x, collapse = ", "), ")", sep = "") )
cat("probability (", node, "|", paste(parents, collapse = ", "),
") {\n", file = fd)
for (i in seq_along(configs)) {
probs = cpt[nlevels * (i - 1) + seq(nlevels)]
# paper over missing values with a uniform distribution
if (all(is.na(probs)))
probs = rep(1, length(probs))/length(probs)
probs = paste(format(probs, nsmall = 1), collapse = ", ")
cat(" ", configs[i], paste(probs, ";\n", sep = ""), file = fd)
}#FOR
cat("}\n", file = fd)
}#THEN
}#BIF.WRITE.PROBABILITIES
net.write.node = function(node, levels, fd) {
cat("node", node, "\n{\n states = (", paste("\"", paste(levels,
collapse = "\" \""), "\"", sep = ""), ");\n}\n", file = fd)
}#NET.WRITE.NODE
net.write.probabilities = function(node, nlevels, cpt, parents, fd) {
if (length(parents) == 0) {
probs = paste(format(cpt, nsmall = 1))
cat("potential (", node, ") \n{\n", file = fd)
cat(" data = (", probs, ");\n}\n", file = fd)
}#THEN
else {
cat("potential (", node, "|", paste(parents, collapse = " "),
") \n{\n data = ", file = fd)
# in NET files the "most significant" variable for the ordering is the
# last one, not the first one.
configs = sanitize.levels(dimnames(cpt))
configs = expand.grid(configs[1+rev(1:length(parents))])
configs = configs[rev(1:ncol(configs))]
indexes = configurations(configs, factor = FALSE)
# paste CPT columns together and save them in the right order.
probs = character(length(indexes))
for (i in seq_along(indexes)) {
temp.probs = cpt[nlevels * (indexes[i] - 1) + seq(nlevels)]
# paper over missing values with a uniform distribution
if (all(is.na(temp.probs)))
temp.probs = rep(1, length(temp.probs))/length(temp.probs)
probs[i] = paste(format(temp.probs, nsmall = 1), collapse = " ")
probs[i] = paste("(", probs[i], ")", sep = "")
}#FOR
# add braces in the proper places.
parents.nlevels = dim(cpt)[-1]
for (i in rev(parents.nlevels)) {
blocks = (i - 1 + seq_along(probs)) %/% i
blocks = lapply(seq(max(blocks)), function(x) probs[blocks == x])
probs = sapply(blocks, function(x) paste("(", paste(x, collapse = ""), ")",
sep = "", collapse = ""))
}#FOR
cat(probs, ";\n}\n", file = fd)
}#ELSE
}#NET.WRITE.PROBABILITIES
dsc.write.node = function(node, levels, fd) {
cat("node", node, "{\n type : discrete [", length(levels),
"] = {", paste("\"", paste(levels, collapse = "\", \""), "\"", sep = ""),
"};\n}\n", file = fd)
}#DSC.WRITE.NODE
dsc.write.probabilities = function(node, nlevels, cpt, parents, fd) {
if (length(parents) == 0) {
probs = paste(format(cpt, nsmall = 1), collapse = ", ")
cat("probability (", node, ") {\n", file = fd)
cat(" ", paste(probs, ";\n", sep = ""), file = fd)
cat("}\n", file = fd)
}#THEN
else {
configs = expand.grid(lapply(dim(cpt)[-1], function(x) seq(x) - 1), stringsAsFactors = FALSE)
configs = apply(configs, 1, function(x) paste("(", paste(x, collapse = ", "), ")", sep = "") )
cat("probability (", node, "|", paste(parents, collapse = ", "),
") {\n", file = fd)
for (i in seq_along(configs)) {
probs = cpt[nlevels * (i - 1) + seq(nlevels)]
# paper over missing values with a uniform distribution
if (all(is.na(probs)))
probs = rep(1, length(probs))/length(probs)
probs = paste(format(probs, nsmall = 1), collapse = ", ")
cat(" ", configs[i], ":", paste(probs, ";\n", sep = ""), file = fd)
}#FOR
cat("}\n", file = fd)
}#ELSE
}#DSC.WRITE.PROBABILITIES
# export graph structures as DOT files.
write.dot.backend = function(fd, graph) {
if (is(graph, "bn"))
arcs = graph$arcs
else
arcs = fit2arcs(graph)
nodes = .nodes(graph)
if (nrow(arcs) == 0) {
# this is an empty graph, we assume it's (partially) directed.
cat("digraph {\n", file = fd)
cat(paste(' "', nodes(graph), '" ;'), sep = "\n")
cat("}\n", file = fd)
}#THEN
else {
wund = which.undirected(arcs, nodes)
type = ifelse(how.many(wund) == nrow(arcs), "graph", "digraph")
if (type == "graph") {
dedup = match(arcs[, "from"], nodes) < match(arcs[, "to"], nodes)
und = apply(arcs[wund & dedup, , drop = FALSE], 1,
function(x) paste('"', x, '"', sep = "", collapse = " -- "))
# this is an undirected graph.
cat("graph {\n", file = fd)
cat(paste(' "', nodes(graph), '" ;', sep = ""), sep = "\n", file = fd)
cat(paste(" edge [dir=none]", und, ";\n"), sep = "", file = fd)
cat("}\n", file = fd)
}#THEN
else if (type == "digraph") {
# this is a (partially) directed graph.
cat("digraph {\n", file = fd)
dir = apply(arcs[!wund, , drop = FALSE], 1,
function(x) paste('"', x, '"', sep = "", collapse = " -> "))
cat(paste(' "', nodes(graph), '" ;', sep = ""), sep = "\n", file = fd)
if (any(wund)) {
dedup = match(arcs[, "from"], nodes) < match(arcs[, "to"], nodes)
und = apply(arcs[wund & dedup, , drop = FALSE], 1,
function(x) paste('"', x, '"', sep = "", collapse = " -> "))
cat(paste(" edge [dir=none]", und, ";\n"), sep = "", file = fd)
}#THEN
cat(paste(" edge [dir=forward]", dir, ";\n"), sep = "", file = fd)
cat("}\n", file = fd)
}#ELSE
}#ELSE
}#WRITE.DOT.BACKEND
Try the bnlearn package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.