#* Utility functions for plotting Hyde Networks without the deterministic nodes
#* plot_nondeterm_only is the main function in this process. It systematically
#* searches each node for deterministic parents. When a deterministic parent
#* is found, it scans that node's parents, and so on until there are no more
#* deterministic parents in the chain.
#*
#* It then uses the information about parents to fit a new HydeNetwork,
#* pulls the attributes relevant to plotting from the original,
#* and returns the modified object for plotting.
plot_nondeterm_only <- function(network){
non_determ_nodes <-
network[["nodes"]][!vapply(X = network$nodeType,
FUN = function(x) x == "determ",
FUN.VALUE = logical(1))]
non_determ_nodes <- non_determ_nodes[!is.na(non_determ_nodes)]
form_parts <-
vapply(X = non_determ_nodes,
FUN = non_determ_parents_form,
FUN.VALUE = character(1),
network)
form <- as.formula(paste0(" ~ ", paste0(form_parts, collapse = " + ")))
newNet <- HydeNetwork(form)
newNet[["nodeType"]] <- network[["nodeType"]][newNet[["nodes"]]]
newNet[["nodeUtility"]] <- network[["nodeUtility"]][newNet[["nodes"]]]
newNet[["nodeDecision"]] <- network[["nodeDecision"]][newNet[["nodes"]]]
newNet
}
#* Creates a portion of the HydeNet formula pertaining to a specific node
#* The while loop searches up the parent-chain until none of the
#* ancestry shows up as deterministic.
non_determ_parents_form <- function(node, network)
{
parent_types <- parent_type(node, network)
while(any(determ_parent(parent_types)))
{
have_determ <- names(parent_types)[determ_parent(parent_types)]
super_parents <- do.call("c", lapply(X = names(parent_types[have_determ]),
FUN = parent_type,
network))
parent_types <- c(parent_types[!names(parent_types) %in% have_determ],
super_parents)
}
form <- paste0(node, " | ",
paste0(unique(names(parent_types)),
collapse = " * "))
gsub(pattern = " [|] $",
replacement = "",
x = form)
}
#* Utility function to extract the nodeType of the parent
parent_type <- function(node, network)
{
network[["nodeType"]][network[["parents"]][[node]]]
}
#* Return a logical vector for the parent nodes indicating if they are deterministic
determ_parent <- function(parent_types)
{
vapply(X = parent_types,
FUN = function(pt) "determ" %in% pt,
FUN.VALUE = logical(1))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.