# Part of the "parental" package, http://github.com/rjbgoudie/parental
#
# This software is distributed under the GPL-3 license. It is free,
# open source, and has the attribution requirements (GPL Section 7) in
# http://github.com/rjbgoudie/parental
#
# Note that it is required that attributions are retained with each function.
#
# Copyright 2008 Robert J. B. Goudie, University of Warwick
#' The parental package.
#'
#' The package \code{parental} provides lightweight tools for creating,
#' modifying network/graph objects. The emphasis is on representing
#' Bayesian Networks, so the focus is on Directed Acyclic Graphs.
#'
#' @import lattice grid
#' @docType package
#' @name package-parental
#' @aliases package-parental
#' @seealso Constructors for objects: \code{\link{parental}},
#' \code{\link{bn}}, \code{\link{bvsresponse}}, \code{\link{bvs}}.
#' Particular graphs: \code{\link{complete}}, \code{\link{empty}}.
#' Plotting: \code{\link{grplot}}.
#' Properties: \code{\link{nNodes}}, \code{\link{nEdges}},
#' \code{\link{indegrees}}, \code{\link{checkAcyclic}},
#' \code{\link{topologicallyOrder}}, \code{\link{routes}}.
#' Collections of objects: \code{\link{parental.list}},
#' \code{\link{bn.list}}
#' Conversion to/from other graph objects: \code{\link{as.parental}},
#' \code{\link{as.bn}}.
#' Routes matrices: \code{\link{routes}}, \code{\link{routesAddEdge}},
#' \code{\link{routesRemoveEdge}}
#' Random Bayesian network: \code{\link{sampleBN}}
#' Draw data from a Bayesian network: \code{\link{simulate.bn}}
#' @examples
#' # A `bn` object is created by specifying the parents of each node.
#' x <- bn(c(2), c(), c(1, 2))
#' grplot(x)
#'
#' # A `bn` object can be converted to an adjacency matrix
#' adj <- matrix(c(0, 0, 1, 1, 0, 0, 0, 0, 0), 3, 3)
#' x <- as.bn(adj)
#' grplot(x)
#'
#' # A `bn` object can be converted to an adjacency matrix
#' x <- bn(c(2), c(), c(1, 2))
#' as.adjacency(x)
#'
#' # Properties of a `bn`
#' x <- bn(c(2), c(), c(1, 2))
#' nNodes(x)
#' nEdges(x)
#' indegrees(x)
#' checkAcyclic(x)
#' topologicallyOrder(x)
#'
#' # Manipulating `bn` objects
#' x <- bn(c(2), c(), c(1, 2))
#'
#' # Fast, but less intuitive manipulation of `bn` objects
#' x <- bn(c(2), c(), c(1, 2))
#' x[[1]] <- c()
#' x
#' x[[2]] <- 1
#' x
#'
#' # Sample a BN
#' sampleBN(10)
#' sampleBN(10, maxNumberParents = 2)
#'
#' # An empty graph
#' empty(10, "bn")
#'
#' # Enumerate all the Bayesian Networks
#' enumerateBNSpace(3)
#'
#' # Tools for handling "routes matrices"
#' x <- bn(c(2), c(), c(1, 2))
#' routes(x)
#'
#' # Simulate from a `bn`
#' cpt <- list(
#' as.table(array(c(0.7, 0.3), 2)),
#' as.table(array(c(0.5, 0.5, 0.2, 0.8), c(2, 2)))
#' )
#' net <- bn(c(), 1)
#' sim <- simulate(object = net, nsim = 1000, ptables = cpt)
NULL
.onLoad <- function(libname, pkgname){
cat("copyright (c) 2008, Robert J. B. Goudie, University of Warwick\n")
cat('For citation information, type citation("parental").\n')
cat('Type help("package-parental") to get started.\n')
}
#' Constructor function for a \code{parental} object.
#'
#' Objects of class \code{parental} are lists with the ith component
#' specifyingthe parents of node i. The parents must be specified as a
#' vector of integers -- the storage.mode() of these integers MUST be
#' integer. If the node has no parents, use integer(0).
#'
#' Note, in particular, that \code{list(2, 1)} would not be a valid
#' \code{parental} object, because storage.mode(2) and
#' \code{storage.mode(1) == "double"}. Instead one would use
#' \code{list(2L, 1L)}, as documented in the R FAQ (see [1])
#'
#' Parents of each node MUST be sorted in increasing order.
#' Conformance with object requirements can be tested by \code{is.valid()}
#'
#' [1] http://cran.r-project.org/doc/manuals/R-lang.html#Constants
#'
#' @param ... A series of vectors specifying the parents of each node. These
#' vectors must be of \code{storage.mode} "integer".
#' @return An object of class \code{parental}.
#' @keywords constructor
#' @export
#' @seealso \code{\link{bn}}
#' @examples
#' parental(c(), 1, 2)
#' parental(3, c(), 1)
#' parental(c(), c(1, 3), c())
parental <- function(...){
parents <- list(...)
parents <- lapply(parents, as.integer)
parents <- lapply(parents, sort.int)
class(parents) <- "parental"
parents
}
#' Constructor function for a 'bn' object.
#'
#' \code{bn} is a subclass of \code{parental}. See \code{\link{parental}}
#' for detailed documentation.
#'
#' @param ... A series of vectors specifying the parents of each node.
#' These vectors must be of storage.mode "integer".
#' @return An object of class 'bn'.
#' @export
#' @seealso \code{\link{parental}}
#' @examples
#' bn(c(), 1, 2)
bn <- function(...){
parents <- list(...)
parents <- lapply(parents, as.integer)
parents <- lapply(parents, sort.int)
class(parents) <- c("bn", "parental")
parents
}
#' Constructor function for a 'bvs' object.
#'
#' 'bvs' is a subclass of \code{parental}. See \code{\link{parental}}
#' for detailed documentation.
#'
#' @param ... A series of vectors specifying the parents of each node.
#' These vectors must be of storage.mode "integer".
#' @return An object of class 'bvs'.
#' @export
bvs <- function(...){
parents <- list(...)
parents <- lapply(parents, as.integer)
parents <- lapply(parents, sort.int)
class(parents) <- c("bvs", "bn", "parental")
parents
}
#' Constructor function for a 'parental list' object.
#'
#' @param ... A series of objects of class \code{parental}.
#' @return An object of class 'parental.list'
#' @export
#' @seealso \code{\link{parental}}, \code{\link{bn.list}},
#' \code{\link{[.parental.list}}, \code{\link{c.parental.list}}
#' @examples
#' p1 <- parental(c(), c(1), c(1, 2, 4), c(3))
#' p2 <- parental(c(2), c(), c(4), c(2, 3))
#' x <- parental.list(p1, p2)
parental.list <- function(...){
parentallist <- list(...)
class(parentallist) <- c("parental.list")
parentallist
}
#' Extract parts of a 'parental list'.
#'
#' Operator that acts on objects of class \code{parental.list} to extract
#' parts of the list
#'
#' @param x Object from which to extract element(s)
#' @param i Indicies specifying elements to extract
#' @return An object of class \code{parental.list}, consisting the parts of
#' \code{x} indicated by \code{i}
#' @S3method "[" parental.list
#' @method "[" parental.list
#' @aliases [.parental.list
#' @usage \method{[}{parental.list}(x, i)
#' @name getpl
#' @seealso \code{\link{parental.list}}, \code{\link{c.parental.list}}
#' @examples
#' p1 <- parental(c(), c(1), c(1, 2, 4), c(3))
#' p2 <- parental(c(2), c(), c(4), c(2, 3))
#' x <- parental.list(p1, p2)
#' x[1]
#' x[[1]]
#' x[2]
"[.parental.list" <- function(x, i){
x <- unclass(x)[i]
class(x) <- "parental.list"
x
}
#' Constructor function for a 'bn list'.
#'
#' Constructs bn.list objects
#'
#' @param ... A series of objects of class 'bn'.
#' @return An object of class 'bn.list'
#' @export
#' @seealso \code{\link{[.bn.list}}, \code{\link{c.bn.list}}
#' @examples
#' p1 <- bn(c(), c(1), c(1, 2, 4), c())
#' p2 <- bn(c(2), c(), c(1), c())
#' x <- bn.list(p1, p2)
#' x[1]
#' x[[1]]
#' x[2]
bn.list <- function(...){
bnlist <- list(...)
class(bnlist) <- c("bn.list", "parental.list")
bnlist
}
#' Extract parts of a 'bn list'.
#'
#' Operator that acts on objects of class \code{bn.list} to extract
#' parts of the list
#'
#' @param x Object from which to extract element(s)
#' @param i Indicies specifying elements to extract
#' @return An object of class \code{bn.list}, consisting the parts of
#' \code{x} indicated by \code{i}
#' @name getbnl
#' @aliases [.bn.list
#' @usage \method{[}{bn.list}(x, i)
#' @S3method "[" bn.list
#' @method "[" bn.list
#' @seealso \code{\link{bn.list}}
#' @examples
#' p1 <- bn(c(), c(1), c(1, 2, 4), c())
#' p2 <- bn(c(2), c(), c(1), c())
#' x <- bn.list(p1, p2)
#' x[1]
#' x[[1]]
#' x[2]
"[.bn.list" <- function(x, i){
x <- unclass(x)[i]
class(x) <- c("bn.list", "parental.list")
x
}
#' Constructor function for a 'bvsresponse list' object.
#'
#' @param ... A series of objects of class 'bvsresponse'.
#' @return An object of class 'bvsresponse.list'
#' @export
bvsresponse.list <- function(...){
bvsrlist <- list(...)
class(bvsrlist) <- "bvsresponse.list"
bvsrlist
}
#' Extract parts of a 'bvsresponse list'.
#'
#' Operator that acts on objects of class \code{bvsresponse.list} to extract
#' parts of the list
#'
#' @param x Object from which to extract element(s)
#' @param i Indicies specifying elements to extract
#' @return An object of class \code{bvsresponse.list}, consisting the parts
#' of \code{x} indicated by \code{i}
#' @name getbvsrl
#' @aliases [.bvsresponse.list
#' @usage \method{[}{bvsresponse.list}(x, i)
#' @S3method "[" bvsresponse.list
#' @method "[" bvsresponse.list
"[.bvsresponse.list" <- function(x, i){
x <- unclass(x)[i]
class(x) <- "bvsresponse.list"
x
}
#' Check validity.
#'
#' Checks the validity of objects
#'
#' @param x Object to check for validity
#' @return A logical indicating validity.
#' @seealso \code{\link{is.valid.parental}},
#' \code{\link{is.valid.bn}}, \code{\link{is.valid.bvs}},
#' \code{\link{is.valid.bvsresponse}}
#' @export
is.valid <- function(x){
UseMethod("is.valid")
}
#' Check validity.
#'
#' Checks whether the supplied \code{parental} is valid.
#' Tests that the parents are sorted correctly, are of
#' storage.mode() == "integer"
#'
#' @param x A object of class \code{parental}
#' @return A logical of length 1 indicating whether x is a valid
#' \code{parental} object
#' @S3method is.valid parental
#' @method is.valid parental
#' @seealso \code{\link{is.valid.bn}}
#' @examples
#' x <- parental(c(), c(1), c(1, 2, 4), c(3))
#' is.valid(x)
is.valid.parental <- function(x){
stopifnot("parental" %in% class(x))
tryCatch({
sorted <- all(!sapply(x, is.unsorted)) # check all components sorted
ints <- all(sapply(x, storage.mode) == "integer") # all ints
if (all(c(sorted, ints))){
T
}
else {
F
}
},
error = function(e) F)
}
#' Check validity.
#'
#' Checks whether the supplied 'bvs' is valid.
#' Tests that the parents are sorted correctly, are of
#' storage.mode() == "integer".
#' Additionally tests that there is a unique response.
#'
#' @param x A object of class 'bvs'
#' @return A logical of length 1 indicating whether x is a valid 'bvs'
#' object.
#' @S3method is.valid bvs
#' @method is.valid bvs
is.valid.bvs <- function(x){
stopifnot("bvs" %in% class(x))
tryCatch({
sorted <- all(!sapply(x, is.unsorted)) # check all components sorted
ints <- all(sapply(x, storage.mode) == "integer") # all ints
# check only one response, or could be the empty graph
resp <- sum(sapply(x, length) > 0) %in% c(0, 1)
if (all(c(sorted, ints, resp))){
T
}
else {
F
}
},
error = function(e) F)
}
#' Check validity.
#'
#' Checks whether the supplied 'bn is valid.
#' Tests that the parents are sorted correctly, are of
#' storage.mode() == "integer".
#' Additionally checks that the supplied bn is acyclic.
#'
#' @param x A object of class 'bn'
#' @return A logical of length 1 indicating whether x is a valid 'bn' object
#' @S3method is.valid bn
#' @method is.valid bn
#' @seealso \code{\link{is.valid.parental}}
#' @examples
#' x <- bn(c(), 1, 2)
#' is.valid(x)
is.valid.bn <- function(x){
stopifnot("bn" %in% class(x),
"parental" %in% class(x))
tryCatch({
sorted <- all(!sapply(x, is.unsorted)) # check all components sorted
ints <- all(sapply(x, storage.mode) == "integer") # all ints
acyclic <- checkAcyclic(x)
if (all(c(sorted, ints, acyclic))){
T
}
else {
F
}
},
error = function(e) F)
}
#' Concatenates 'parental list'.
#'
#' @param ... Any number of 'parental.list' objects
#' @return An new 'parental.list' object, including all the supplied
#' parental.lists
#' @S3method c parental.list
#' @method c parental.list
#' @seealso \code{\link{parental.list}}, \code{\link{[.parental.list}}
#' @examples
#' p1 <- parental(c(), c(1), c(1, 2, 4), c(3))
#' p2 <- parental(c(2), c(), c(4), c(2, 3))
#' x <- parental.list(p1, p2)
#' y <- parental.list(p1, p1)
#' c(x, y)
c.parental.list <- function(...){
out <- NextMethod("c")
class(out) <- "parental.list"
out
}
#' Concatenates 'bn list'.
#'
#' @param ... Any number of 'bn.list' objects
#' @return An new 'bn.list' object, including all the supplied bn.lists
#' @S3method c bn.list
#' @method c bn.list
#' @seealso \code{\link{bn.list}}, \code{\link{[.bn.list}}
#' @examples
#' p1 <- bn(c(), c(1), c(1, 2, 4), c())
#' p2 <- bn(c(2), c(), c(1), c())
#' x <- bn.list(p1, p2)
#' y <- bn.list(p2, p2, p1)
#' c(x, y)
c.bn.list <- function(...){
out <- NextMethod("c")
class(out) <- c("bn.list", "parental.list")
out
}
#' Prints 'parental list'.
#'
#' @param x A 'parental.list' object
#' @param ... Further arguments, currently unused.
#' @return Prints the 'parental.list' object to the console.
#' @S3method print parental.list
#' @method print parental.list
#' @seealso \code{\link{parental.list}}
#' @examples
#' p1 <- parental(c(), c(1), c(1, 2, 4), c(3))
#' p2 <- parental(c(2), c(), c(4), c(2, 3))
#' x <- parental.list(p1, p2)
#' x
print.parental.list <- function(x, ...){
print(unlist(lapply(x, as.character, pretty = T)))
}
#' Prints 'parental'.
#'
#' @param x A \code{parental} object
#' @param ... Further arguments, currently unused
#' @return Prints the \code{parental} object to the console.
#' @S3method print parental
#' @method print parental
#' @seealso \code{\link{parental}}
#' @examples
#' p1 <- parental(c(), c(1), c(1, 2, 4), c(3))
#' p1
print.parental <- function(x, ...){
print(as.character(x, pretty = T))
}
#' Prints 'bn'.
#'
#' @param x A 'bn' object
#' @param ... Further arguments (unused)
#' @return Prints the 'bn' object to the console.
#' @S3method print bn
#' @method print bn
#' @seealso \code{\link{bn}}
#' @examples
#' x <- bn(c(), 1, 2)
#' x
print.bn <- function(x, ...){
print(as.character(x, pretty = T))
}
#' Rename nodes.
#'
#' A generic for renaming nodes
#'
#' @param x Object to rename
#' @param ... Further arguments, passed to method
#' @seealso \code{\link{renameNodes.parental.list}}
#' @export
renameNodes <- function(x, ...){
UseMethod("renameNodes")
}
#' Rename nodes.
#'
#' Return the parental list, with nodes in each parental
#' in the parental.list renamed to the newnames.
#'
#' @param x A parental.list
#' @param newnames A character vector specifying the new names for the
#' nodes
#' @param ... Further arguments, currently unused
#'
#' @return The parental.list with renamed nodes
#' @S3method renameNodes parental.list
#' @method renameNodes parental.list
renameNodes.parental.list <- function(x, newnames, ...){
stopifnot(
"parental.list" %in% class(x),
class(newnames) == "character",
all(length(newnames) == sapply(x, length)) # the number of names match
# number of nodes
)
oldclass <- class(x)
res <- lapply(x, function(parental){
names(parental) <- newnames
parental
})
class(res) <- oldclass
res
}
#' Return a complete graph.
#'
#' @param n the number of nodes
#' @return A complete \code{parental} graph
#' @export
#' @seealso \code{\link{empty}}, \code{\link{parental}}
#' @examples
#' complete(5)
complete <- function(n){
stopifnot(class(n) %in% c("numeric", "integer"),
n >= 1,
length(class) == 1)
nodeSeq <- seq_len(n)
res <- do.call(list, lapply(seq_len(n), function(i){
as.integer(sort.int(setdiff(nodeSeq, i)))
}))
class(res) <- "parental"
res
}
#' Return empty graph.
#'
#' Returns an empty graph with n nodes, of the given class
#'
#' @param n A integer of length 1, specifying the number of nodes
#' @param class The class of the returned graph. Can be any of "parental",
#' "bn", "bvs", or "bvsresponse".
#' @param response For "bvsresponse", which node is the response
#' @return An empty graph of the specified class.
#' @export
#' @seealso \code{\link{complete}}, \code{\link{parental}}, \code{\link{bn}}
#' @examples
#' empty(5)
#' empty(5, "bn")
empty <- function(n, class = "parental", response){
stopifnot(class(n) %in% c("numeric", "integer"),
n >= 1,
length(class) == 1,
class %in% c("parental", "bn", "bvs", "bvsresponse"))
if (class == "parental"){
outclass <- "parental"
}
else if (class == "bn"){
outclass <- c("bn", "parental")
}
else if (class == "bvs"){
outclass <- c("bvs", "bn", "parental")
}
else if (class == "bvsresponse"){
stopifnot(!missing(response))
outclass <- "bvs" # temporary to allow method dispatch as.bvsresponse
}
res <- do.call(list, lapply(seq_len(n), function(i){
integer(0)
}))
class(res) <- outclass
if (class == "bvsresponse"){
res <- as.bvsresponse(res, response = response)
}
res
}
#' Checks validity.
#'
#' Checks whether the supplied 'bvsresponse' is valid.
#' Tests that the parents are sorted correctly, are of
#' storage.mode() == "integer".
#' Additionally tests the parents all exist.
#'
#' @param x A object of class 'bvsresponse'
#' @return A logical of length 1 indicating whether x is a valid
#' 'bvsresponse' object
#' @S3method is.valid bvsresponse
#' @method is.valid bvsresponse
is.valid.bvsresponse <- function(x){
stopifnot("bvsresponse" %in% class(x))
if (any(is.null(x$parents), is.null(x$response), is.null(x$nNodes))){
F
}
else {
if (!all(length(x$nNodes) == 1, length(x$response) == 1)){
F
}
else {
sorted <- !is.unsorted(x$parents) # check all components sorted
ints <- storage.mode(x$parents) == "integer" # all ints
maxNotTooHigh <- length(x$parents) == 0 || all(x$parents <= x$nNodes)
minNotTooLow <- length(x$parents) == 0 || all(x$parents >= 1L)
responseWhole <- round(x$response) == x$response
nNodesWhole <- round(x$nNodes) == x$nNodes
responseNotInParents <- !x$response %in% x$parents
responseNotTooHigh <- x$response <= x$nNodes
isvalid <- all(c(sorted, ints, maxNotTooHigh, minNotTooLow,
responseWhole, nNodesWhole, responseNotInParents))
if (isvalid){
T
}
else {
F
}
}
}
}
#' Construct 'bvsreponse'.
#'
#' Constructor function for a 'bvsresponse' object.
#' Objects of class 'bvsresponse' are lists, with the following components:
#'
#' $parents: A vectors of integers, specifying the parents of the response.
#' The parents must be specified as a vector of integers -- the
#' storage.mode() of these integers MUST be integer. If the node has no
#' parents, use integer(0).
#'
#' Note, in particular, that c(2, 1) would not be a valid specification
#' of 'parents', because storage.mode(2) and storage.mode(1) == "double"
#' Instead one would use c(2L, 1L), as documented in the R FAQ (see [1])
#'
#' Parents of each node MUST be sorted in increasing order.
#' Conformance with object requirements can be tested by is.valid()
#'
#' [1] http://cran.r-project.org/doc/manuals/R-lang.html#Constants
#'
#' @param x A vector of integers specifying the parents of the response.
#' @param response A integer of length 1 specifying which node (column)
#' is the response.
#' @param nNodes The number of nodes (columns) in the variable selection.
#' @return An object of class 'bvsresponse'.
#' @export
bvsresponse <- function(x, response, nNodes){
stopifnot(class(x) == "integer",
is.numeric(x),
length(response) == 1,
is.numeric(nNodes),
length(nNodes) == 1,
all(x <= nNodes),
all(x >= 1),
!response %in% x)
res <- list(parents = x,
response = as.integer(response),
nNodes = as.integer(nNodes))
class(res) <- "bvsresponse"
res
}
#' Prints 'bvsresponse'.
#'
#' Prints a 'bvsresponse' object to the console.
#'
#' @param x A 'bvsresponse' object
#' @param ... Further arguments, currently unused
#' @return Prints the 'bvsresponse' object to the console.
#' @S3method print bvsresponse
#' @method print bvsresponse
print.bvsresponse <- function(x, ...){
cat("bvsresponse. Col ", x$response, " is response. ", sep = "")
cat(x$nNodes, " variables. ", sep = "")
if (length(x$parents) > 0){
cat("Parents of response: ", as.character(x), ". ", sep = "")
}
else {
cat("Response has no parents")
}
}
#' Parents.
#'
#' @param x The object for which to get the parents
#' @param i Which node
#' @return The parents
#' @export
#' @examples
#' x <- parental(c(), 1, c(2, 4), c())
#' parents(x, 3)
parents <- function(x, i){
x[[i]]
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.