# Converts a graphnel DAG to anb families.
# Make sure class is last family.
# Make sure class last element in each family.
graphNEL2families <- function(dag, class) {
check_class(class) # Remove?
if (!skip_testing()) stopifnot(is_dag_graph(dag))
parents <- graphNEL_parents(dag)
families <- mapply(make_family, names(parents), parents, class, SIMPLIFY = FALSE)
# Make sure class is the last family
nms <- c(names(parents), NULL) # avoid side-effects
ordered_vars <- make_last_sideeffect(nms, class)
families <- families[ordered_vars]
check_anb_families(families, class)
families
}
# Make class last element of each family
# TODO: maybe should ensure an alphabetic ordering of non-class parents
make_family <- function(var, parents, class) {
# TODO: make_family and make_last should be merged into a single function.
parents <- make_last_sideeffect(parents, class)
c(var, parents)
}
# Returns the variables whose families are these
get_family_vars <- function(families) {
names(families)
}
# Check that the families correspond to an augmented naive Bayes.
check_anb_families <- function(families, class) {
if (skip_assert( )) return (TRUE)
vars <- get_family_vars(families)
# Class must be the last family so that it is also last in vars()
# Check that class has no parents
stopifnot(is_non_empty_complete(vars), is_last(class, vars),
identical(families[[class]], class))
# check each family
fams_ok <- all( mapply(is_anb_family, families, vars,
MoreArgs = list(class = class), SIMPLIFY = TRUE) )
stopifnot(fams_ok)
# Check for cycles
stopifnot(is_dag_families(families))
}
# All elements are non empty characters
# The var is the 1 element of the family, class is the last
is_anb_family <- function(family, var, class) {
is.character(family) && is_non_empty_complete(family) && is_last(class, family) && is_at_pos(var, 1, family)
}
make_families_ids <- function(fams) {
vapply(fams, make_family_id, FUN.VALUE = character(1))
}
make_family_id <- function(fam) {
paste0(fam, collapse = "")
}
family_features <- function(fam, class) {
stopifnot(!are_disjoint(fam, class))
setdiff(fam, class)
}
# Returns the unique families accross these dags. TODO: Standardize families
# first? Does not take into account that same may only differ in the order of
# parents Use duplicated instead of unique in order to preserve the names
unique_families <- function(fams) {
all_fams <- unlist(fams, recursive = FALSE)
all_fams[!duplicated(all_fams)]
}
is_dag_families <- function(families) {
if (skip_assert( )) return (TRUE)
!(is.null(order_acyclic(families)))
}
#' Provide an acyclic ordering (i.e., a topological sort).
#' @references Beng-Jensen and Gutin, 2007, page 14.
#' @keywords internal
order_acyclic <- function(families) {
# Empty list of nodes in acyclic ordering
order <- character()
not_in_acyc_order <- rep(TRUE, length(families))
nodes <- get_families_nodes(families)
# Get the parents here for efficiency
family_parents <- lapply(families, get_family_parents)
while (sum(not_in_acyc_order) > 0) {
# Get nodes not in list and without parents among them
can_be_added <- vapply(family_parents[not_in_acyc_order], are_disjoint,
nodes[not_in_acyc_order], FUN.VALUE = logical(1))
if (sum(can_be_added) == 0) { break }
# Add them to end of the acyclic ordering
to_add <- nodes[not_in_acyc_order][can_be_added]
order <- append(order, to_add)
not_in_acyc_order <- !(nodes %in% order)
}
if (length(nodes) != length(order)) {
# if (!is_perm(nodes, order)) { Too slow.
# There is a cycle
NULL
}
else {
# Return acyclic ordering
order
}
}
get_families_nodes <- function(families) {
unname(vapply(families, get_family_node,
FUN.VALUE = character(1)))
}
get_family_node <- function(family) {
family[1]
}
get_family_parents <- function(family) {
family[-1]
}
#' Based on gRbase::ancestors()
#' @keywords internal
get_ancestors <- function(node, families) {
stopifnot(node %in% names(families))
find_my_parents <- node
ancestors <- character()
# while find_my_parents not empty
while (length(find_my_parents) > 0) {
# get unique parents of all find_my_parents
parents <- unique(unlist(lapply(families[find_my_parents],
get_family_parents), use.names = FALSE))
# set find_my_parents ot parents that are not in ancestors
new_parents <- setdiff(parents, ancestors)
find_my_parents <- new_parents
# add the new parents to ancestors
ancestors <- append(ancestors, new_parents)
}
ancestors
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.