R/frontend-nodes.R

In vspinu/bnlearn: Bayesian network structure learning, parameter learning and inference

# return the markov blanket of a node.
mb = function(x, node) {

  # check x's class.
  check.bn.or.fit(x)
  # a valid node is needed.
  check.nodes(nodes = node, graph = x, max.nodes = 1)

  if (is(x, "bn"))
    x$nodes[[node]]$mb
  else
    mb.fitted(x, node)

}#MB

# return the neighbourhood of a node.
nbr = function(x, node) {

  # check x's class.
  check.bn.or.fit(x)
  # a valid node is needed.
  check.nodes(nodes = node, graph = x, max.nodes = 1)

  if (is(x, "bn"))
    x$nodes[[node]]$nbr
  else
    unique(c(x[[node]]$parents, x[[node]]$children))

}#NBR

# get the parents of a node.
parents = function(x, node) {

  # check x's class.
  check.bn.or.fit(x)
  # a valid node is needed.
  check.nodes(nodes = node, graph = x, max.nodes = 1)

  if (is(x, "bn"))
    x$nodes[[node]]$parents
  else
    x[[node]]$parents

}#PARENTS

# add one or more parents to a node.
"parents<-" = function(x, node, debug = FALSE, value) {

  # check x's class.
  check.bn(x)
  # a valid node is needed.
  check.nodes(nodes = node, graph = x, max.nodes = 1)
  # at least one parent node is needed.
  if (missing(value))
    stop("no parent specified.")
  # node must be a valid node label.
  if (!any(value %in% names(x$nodes)))
    stop("node not present in the graph.")

  # remove duplicate labels from value.
  value = unique(value)
  # drop the parents which are not listed for inclusion.
  to.be.dropped = x$nodes[[node]]$parents[!(x$nodes[[node]]$parents %in% value)]
  # add only the nodes that were not already there.
  to.be.added = value[!(value %in% x$nodes[[node]]$parents)]

  if (debug) {

    cat("* resetting the parents of node", node, ".\n")
    cat("  > old parents: '", x$nodes[[node]]$parents, "'\n")
    cat("  > new parents: '", value, "'\n")
    cat("  > to be really dropped: '", to.be.dropped, "'\n")
    cat("  > to be really added: '", to.be.added, "'\n")

  }#THEN

  # dropping!
  for (p in to.be.dropped) {

    x = arc.operations(x = x, from = p, to = node, op = "drop",
      check.cycles = FALSE, update = FALSE, debug = debug)

  }#FOR

  # adding!
  for (p in to.be.added) {

    x = arc.operations(x = x, from = p, to = node, op = "set",
      check.cycles = TRUE, update = FALSE, debug = debug)

  }#FOR

  # update the network structure.
  x$nodes = cache.structure(names(x$nodes), arcs = x$arcs, debug = debug)

  x

}#PARENTS<-

# get the children of a node.
children = function(x, node) {

  # check x's class.
  check.bn.or.fit(x)
  # a valid node is needed.
  check.nodes(nodes = node, graph = x, max.nodes = 1)

  if (is(x, "bn"))
    x$nodes[[node]]$children
  else
    x[[node]]$children

}#CHILDREN

# add one or more children to a node.
"children<-" = function(x, node, debug = FALSE, value) {

  # check x's class.
  check.bn(x)
  # a valid node is needed.
  check.nodes(nodes = node, graph = x, max.nodes = 1)
  # a node is needed.
  if (missing(value))
    stop("no children specified.")
  # node must be a valid node label.
  if (!any(value %in% names(x$nodes)))
    stop("node not present in the graph.")

  # remove duplicate labels from value.
  value = unique(value)
  # drop the parents which are not listed for inclusion.
  to.be.dropped = x$nodes[[node]]$children[!(x$nodes[[node]]$children %in% value)]
  # add only the nodes that were not already there.
  to.be.added = value[!(value %in% x$nodes[[node]]$children)]

  if (debug) {

    cat("* resetting the children of node", node, ".\n")
    cat("  > old children: '", x$nodes[[node]]$children, "'\n")
    cat("  > new children: '", value, "'\n")
    cat("  > to be really dropped: '", to.be.dropped, "'\n")
    cat("  > to be really added: '", to.be.added, "'\n")

  }#THEN

  # dropping!
  for (child in to.be.dropped) {

    x = arc.operations(x = x, from = node, to = child, op = "drop",
      check.cycles = FALSE, update = FALSE, debug = debug)

  }#FOR

  # adding!
  for (child in to.be.added) {

    x = arc.operations(x = x, from = node, to = child, op = "set",
      check.cycles = TRUE, update = FALSE, debug = debug)

  }#FOR

  # update the network structure.
  x$nodes = cache.structure(names(x$nodes), arcs = x$arcs, debug = debug)

  x

}#CHILDREN<-

# get the in-degree of a node.
in.degree = function(x, node) {

  # check x's class.
  check.bn.or.fit(x)
  # a valid node is needed.
  check.nodes(nodes = node, graph = x, max.nodes = 1)

  if (is(x, "bn"))
    length(x$nodes[[node]]$parents)
  else
    length(x[[node]]$parents)

}#IN.DEGREE

# get the out-degree of a node.
out.degree = function(x, node) {

  # check x's class.
  check.bn.or.fit(x)
  # a valid node is needed.
  check.nodes(nodes = node, graph = x, max.nodes = 1)

  if (is(x, "bn"))
    length(x$nodes[[node]]$children)
  else
    length(x[[node]]$children)

}#OUT.DEGREE


setGeneric("nodes<-", function(object, value) standardGeneric("nodes<-"))


setMethod("nodes<-", c("bn", "ANY"),
          function(object, value){
              value <- as.character(value)
              if(any(duplicated(value)))
                  stop("duplicated names detected: ", value[which(duplicated(value))[[1]]])
              nodes <- names(object$nodes)
              if(length(nodes) != length(value))
                  stop(sprintf("length of new node names (%s) should be equal to the number of nodes in the graph (%s)",
                               length(value), length(nodes)))
              .subst <- function(nms){
                  m <- match(nms, nodes)
                  value[m]
              }

              if(!is.null(object$learning$whitelist))
                  object$learning$whitelist <- .subst(object$lea$whitelist)

              if(!is.null(object$learning$blacklist))
                  object$learning$blacklist <- .subst(object$learning$blacklist)

              object$nodes <- rapply(object$nodes, .subst, how = "replace")
              names(object$nodes) <- .subst(names(object$nodes))

              object$arcs[] <- .subst(object$arcs)
              object
          })