R/nodes_keep_drop.R

In semptools: Customizing Structural Equation Modelling Plots

#'@title Keep or drop nodes
#'
#'@description Keep or drop nodes from an semPlotModel object.
#'
#'@details These functions can be used to edit the nodes in an
#'[`semPlot::semPlotModel`] generated by [semPlot::semPlotModel()].
#'The edited object can then be passed to [semPlot::semPaths()] to
#'generate a path diagram.
#'
#'Use [keep_nodes()] to specify the nodes to be kept. All other nodes
#'will be removed.
#'
#'Use [drop_nodes()] to specify the nodes to be dropped. All other
#'nodes will be kept.
#'
#'@return An object of the class [`semPlot::semPlotModel`].
#'
#'@param object An an [`semPlot::semPlotModel`] generated by
#'              [semPlot::semPlotModel()].
#'
#'@param nodes A character vector of the nodes to be kept or removed.
#'
#'@examples
#'mod_pa <-
#'   'x1 ~~ x2
#'    x3 ~  x1 + x2
#'    x4 ~  x1 + x3
#'   '
#'fit_pa <- lavaan::sem(mod_pa, pa_example)
#'m <- matrix(c("x1",   NA,   NA,
#'              NA, "x3", "x4",
#'              "x2",   NA,   NA), byrow = TRUE, 3, 3)
#'pm_pa <- semPlot::semPlotModel(fit_pa)
#'semPlot::semPaths(pm_pa, whatLabels = "est",
#'                  style = "ram",
#'                  nCharNodes = 0, nCharEdges = 0,
#'                  layout = m)
#'pm_pa2 <- drop_nodes(pm_pa, c("x3"))
#'semPlot::semPaths(pm_pa2, whatLabels = "est",
#'                  style = "ram",
#'                  nCharNodes = 0, nCharEdges = 0,
#'                  layout = m)
#'pm_pa3 <- keep_nodes(pm_pa, c("x1", "x3", "x4"))
#'semPlot::semPaths(pm_pa3, whatLabels = "est",
#'                  style = "ram",
#'                  nCharNodes = 0, nCharEdges = 0,
#'                  layout = m)
#'@name keep_drop_nodes
NULL

#'@rdname keep_drop_nodes
#'@export

drop_nodes <- function(object, nodes) {
    if (!inherits(object, "semPlotModel")) {
        stop("The object is not an semPlotModel object.")
      }
    all_vars <- c(semPlot::man(object), semPlot::lat(object))
    if (length(setdiff(nodes, all_vars)) != 0) {
        warning("One or more variables in 'nodes' are not in the",
                "object. They will be ignored.")
      }
    tmp <- object@Pars
    par_ge0 <- sum(tmp$par > 0)
    tmp <- tmp[!(tmp$lhs %in% nodes | tmp$rhs %in% nodes), ]
    tmp$par[tmp$par > 0] <- seq_len(sum(tmp$par > 0))
    object@Pars <- tmp
    tmp <- object@Vars
    pos_to_keep <- !(tmp[, "name"] %in% nodes)
    object@Vars <- object@Vars[pos_to_keep, ]
    if (length(object@ObsCovs) > 0) {
        tmp <- object@ObsCovs[[1]]
        pos_to_keep <- !(colnames(tmp) %in% nodes)
        object@ObsCovs[[1]] <- tmp[pos_to_keep, pos_to_keep]
    }
    if (length(object@ImpCovs) > 0) {
        tmp <- object@ImpCovs[[1]]
        pos_to_keep <- !(colnames(tmp) %in% nodes)
        object@ImpCovs[[1]] <- tmp[pos_to_keep, pos_to_keep]
    }
    object
  }

#'@rdname keep_drop_nodes
#'@export

keep_nodes <- function(object, nodes) {
    if (!inherits(object, "semPlotModel")) {
        stop("The object is not an semPlotModel object.")
      }
    all_vars <- c(semPlot::man(object), semPlot::lat(object))
    if (length(setdiff(nodes, all_vars)) != 0) {
        warning("One or more variables in 'nodes' are not in the",
                "object. They will be ignored.")
      }
    varnames <- object@Vars[, "name"]
    nodes_to_drop <- varnames[!(varnames %in% nodes)]
    drop_nodes(object, nodes_to_drop)
  }