#' @name update.HydeNetwork
#' @export
#' @method update HydeNetwork
#'
#' @title Update Probabilistic Graphical Network
#' @description Add or remove nodes or add parents within a \code{HydeNetwork}
#' model.
#'
#' @param object A \code{HydeNetwork} object
#' @param formula A formula statement indicating the changes to the network.
#' @param ... Additional arguments to be passed to other methods. Current,
#' none are used.
#'
#' @details Adding or removing nodes is fairly straightforward if you are
#' removing a complete node (along with its parents). Removing a parent
#' will generate a warning that the child nodes may need to be redefined.
#'
#' @author Jarrod Dalton and Benjamin Nutter
#'
#' @examples
#' data(PE, package="HydeNet")
#' Net <- HydeNetwork(~ wells +
#' pe | wells +
#' d.dimer | pregnant*pe +
#' angio | pe +
#' treat | d.dimer*angio +
#' death | pe*treat)
#'
#' plot(Net)
#'
#' Net <- update(Net, . ~ . - pregnant)
#' plot(Net)
#'
update.HydeNetwork <- function(object, formula, ...)
{
new_formula <- rewriteHydeFormula(object[["network_formula"]], formula)
NEW <- HydeNetwork(new_formula, data=object[["data"]])
lostParents <- lapply(names(NEW[["parents"]]),
function(nm){
setdiff(object[["parents"]][[nm]], NEW[["parents"]][[nm]])
})
names(lostParents) <- names(NEW[["parents"]])
if (any(vapply(lostParents, length, numeric(1)) > 0)){
lostParents <- lostParents[vapply(lostParents, length, numeric(1)) > 0]
warning(paste0("The following nodes lost parents in the update--please redefine the node formula:\n",
paste0(" ", names(lostParents), ": ", sapply(lostParents, paste, collapse=", "),
collapse="\n")))
}
NEW[["nodeType"]][names(object[["nodeType"]])] <- object[["nodeType"]]
NEW[["nodeFormula"]][names(object[["nodeFormula"]])] <- object[["nodeFormula"]]
NEW[["nodeFitter"]][names(object[["nodeFitter"]])] <- object[["nodeFitter"]]
NEW[["nodeFitterArgs"]][names(object[["nodeFitterArgs"]])] <- object[["nodeFitterArgs"]]
NEW[["nodeParams"]][names(object[["nodeParams"]])] <- object[["nodeParams"]]
NEW[["nodeData"]][names(object[["nodeData"]])] <- object[["nodeData"]]
return(NEW)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.