R/set_edge_attribute.R

In semptools: Customizing Structural Equation Modelling Plots

#' @title Set the Attributes of Selected Edges
#'
#' @description Set arbitrary
#' attributes of selected edges.
#'
#' @details Modify a [qgraph::qgraph]
#' object generated by
#' [semPlot::semPaths] and change the
#' selected attributes of selected
#' edges.
#'
#' This function is designed to be a
#' general one that changes the
#' attributes named by the user. The
#' user needs to make sure that the
#' attribute actually exists, and the
#' values are valid for the named
#' attribute.
#'
#' ## Setting the value of `values`
#'
#' This argument can be set in two ways.
#'
#' For a named vector, the name of an
#' element should be the path as
#' specified by [lavaan::model.syntax]
#' or as appeared in
#' [lavaan::parameterEstimates()].
#'
#' For example, if the attributes to be
#' changed are the colors of selected
#' edges, to change the color of the
#' path regressing `y` on `x`, the name
#' should be `"y ~ x"`. To change the
#' color of the covariance between `x1`
#' and `x2`, the name should be `"x1 ~~
#' x2"`. Therefore, `c("y ~ x1" = "red",
#' "x1 ~~ x2" = "blue")` changes the
#' colors of the path from `x1` to `y`
#' and the covariance between `x1` and
#' `x2` to `"red"` and `"blue"`,
#' respectively.
#'
#' The order of the two nodes *may*
#' matter for covariances. Therefore, if
#' the attribute of a covariance is not
#' changed, try switching the order of
#' the two nodes.
#'
#' For a list of named lists, each named
#' list should have three named values:
#' `from`, `to`, and `new_value`. The
#' attribute of the edge from `from` to
#' `to` will be set to `new_value`.
#'
#' The second approach is no longer
#' recommended, though kept for backward
#' compatibility.
#'
#' @return A [qgraph::qgraph] based on
#' the original one, with the selected
#' attributes of selected edges changed.
#'
#' @param semPaths_plot A
#' [qgraph::qgraph] object generated by
#' [semPlot::semPaths], or a similar
#' qgraph object modified by other
#' [semptools] functions.
#'
#' @param values A named vector or a
#' list of named list. See the Details
#' section on how to set this argument.
#'
#' @param attribute_name The name of
#' the attribute to be changed.
#'
#' @examples
#' mod_pa <-
#'   'x1 ~~ x2
#'    x3 ~  x1 + x2
#'    x4 ~  x1 + x3
#'   '
#' fit_pa <- lavaan::sem(mod_pa, pa_example)
#' lavaan::parameterEstimates(fit_pa)[, c("lhs", "op", "rhs", "est", "pvalue")]
#' m <- matrix(c("x1",   NA,   NA,
#'                 NA, "x3", "x4",
#'               "x2",   NA,   NA), byrow = TRUE, 3, 3)
#' p_pa <- semPlot::semPaths(fit_pa, whatLabels="est",
#'             style = "ram",
#'             nCharNodes = 0, nCharEdges = 0,
#'             layout = m)
#'
#' my_values_vector <- c("x2 ~~ x1" = "red",
#'                       "x4 ~ x1" = "blue")
#'
#' p_pa2v <- set_edge_attribute(p_pa,
#'                              values = my_values_vector,
#'                              attribute_name = "color")
#' plot(p_pa2v)
#'
#' my_values_list <- list(list(from = "x1", to = "x2", new_value = "red"),
#'                        list(from = "x1", to = "x4", new_value =  "blue"))
#'
#' p_pa2l <- set_edge_attribute(p_pa,
#'                              values = my_values_list,
#'                              attribute_name = "color")
#'
#' plot(p_pa2l)
#'
#' @export

set_edge_attribute <- function(semPaths_plot,
                               values = NULL,
                               attribute_name = NULL) {
    if (is.null(values)) {
        stop("values not specified.")
      }
    if (is.null(attribute_name)) {
        stop("attribute_name not specified.")
      }
    if (missing(semPaths_plot)) {
        stop("semPaths_plot not specified.")
      } else {
        if (!inherits(semPaths_plot, "qgraph")) {
            stop("semPaths_plot is not a qgraph object.")
          }
      }

    # Convert a named vector to a named list
    if (!is.list(values)) {
        values_org <- values
        values <- to_list_of_lists(values,
                                   name1 = "from",
                                   name2 = "to",
                                   name3 = "new_value")
      }

    Nodes_names <- semPaths_plot$graphAttributes$Nodes$names
    Nodes_id <- seq_len(length(Nodes_names))
    names(Nodes_id) <- Nodes_names
    p <- n_edges(semPaths_plot)
    attr_old <- semPaths_plot$graphAttributes$Edges[[attribute_name]]
    if (is.null(attr_old)) {
        stop("attribute_name not a valid attribute of the edges a qgraph object.")
      }

    # Expand if necessary
    if (isTRUE(length(attr_old) == 1)) {
        attr_old <- rep(attr_old, p)
      }

    attr_new <- attr_old
    attr_index <- sapply(values, function(x) {
          edge_index(semPaths_plot, from = x$from, to = x$to)
        })
    attr_new[attr_index] <- sapply(values, function(x) x$new_value)

    # Check bidirectional edges
    values2 <- values[which(semPaths_plot$Edge$bidirectional[attr_index])]
    if (length(values2) > 0) {
        attr_index2 <- sapply(values2, function(x) {
              edge_index(semPaths_plot, from = x$to, to = x$from)
            })
        attr_new[attr_index2] <- sapply(values2, function(x) x$new_value)
      }

    semPaths_plot$graphAttributes$Edges[[attribute_name]] <- attr_new
    semPaths_plot
  }

#' @title The number of edges
#' @noRd

n_edges <- function(object) {
    edges_attr <- object$graphAttributes$Edges
    tmp <- sapply(edges_attr,
                  function(x) {is.null(dim(x))},
                  simplify = TRUE)
    edges_attr <- edges_attr[tmp]
    tmp <- sapply(edges_attr,
                  length)
    max(tmp)
  }

#' @title Fix the name for new_value
#' @noRd

to_new_value <- function(object,
                         original_name = NULL) {
    if (is.null(original_name)) {
        return(object)
      }
    if (is.list(object)) {
        j <- length(object)
        for (k in seq_len(j)) {
            tmp <- names(object[[k]])
            tmp[which(tmp == "new_color")] <- "new_value"
            names(object[[k]]) <- tmp
          }
      } else {
        return(object)
      }
    return(object)
  }