R/change_node_label.R

In semptools: Customizing Structural Equation Modelling Plots

#'@title Change node labels
#'
#'@description Change the labels of selected nodes.
#'
#'@details Modify a [qgraph::qgraph] object generated by
#' [semPlot::semPaths] and change the labels of selected nodes.
#'
#.
#'
#'@return A [qgraph::qgraph] based on the original one, with node
#' attributes of selected nodes modified.
#'
#'@param semPaths_plot A [qgraph::qgraph] object generated by
#' [semPlot::semPaths], or a similar qgraph object modified by other
#' [semptools] functions.
#'
#'@param label_list A list of named lists. Each named list should
#' have two named values: \code{node} and \code{to}. The first part,
#' \code{node}, is a character denoting the label to be changed. It
#' should be as appeared in the qgraph. The second part, \code{to}, is
#' the new label. Expression can be used in \code{to}. A named vector
#' can also be used, with the names being the nodes to be changed, and
#' the values the new labels.
#'
#'@param label.cex Identical to the same argument in
#' [semPlot::semPaths()]. A number tha control the size of labels in
#' the nodes. It has no default. If not set, then this option in the
#' `semPaths_plot` will not be changed.
#'
#'@param label.scale Identical to the same argument in
#' [semPlot::semPaths]. A logical value that determine whether labels
#' wil be scaled (resized) to the nodes they attach to. It has no
#' default. If not set, then this option in the `semPaths_plot` will
#' not be changed.
#'
#'@param label.prop Identical to the same argument in
#' [semPlot::semPaths]. A numeric vector of length equal to the number
#' of nodes. If `label.scale` is `TRUE`, this number is the proportion
#' of the width of a node that its label will be scaled (resized) to.
#' It has no default. If not set, then this option in the
#' `semPaths_plot` will not be changed.
#'
#'@param label.norm Identical to the same argument in
#' [semPlot::semPaths]. It must be a string. All labels as wide as or
#' narrower than this string will have the same font size, while all
#' labels wider than this string will be rescaled to have the same
#' width as this string. It has no default. If not set, then this
#' option in the `semPaths_plot` will not be changed.
#'
#'
#'@examples
#'library(semPlot)
#'library(lavaan)
#'mod_pa <-
#'  'x1 ~~ x2
#'   x3 ~  x1 + x2
#'   x4 ~  x1 + x3
#'  '
#'fit_pa <- sem(mod_pa, pa_example)
#'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 <- semPaths(fit_pa, whatLabels="est",
#'            style = "ram",
#'            nCharNodes = 0, nCharEdges = 0,
#'            layout = m)
#'
#'my_label_list <- list(list(node = "x3", to = "mediator"),
#'                      list(node = "x4", to = expression(gamma)))
#'
#'p_pa2 <- change_node_label(p_pa, my_label_list)
#'plot(p_pa2)
#'
#'@export

change_node_label <- function(semPaths_plot, label_list = NULL,
                              label.cex,
                              label.scale,
                              label.prop,
                              label.norm)
{
    if (is.null(label_list)) {
        rlang::abort("label_list not specified.")
    }
    if (is.vector(label_list) && !is.list(label_list)) {
        # c(x1 = "IV", x2 = expression(gamma)) is not an atomic but is
        # a vector. If converted to a list, it will be a list with
        # one stirng and one expression.
        label_list <- as.list(label_list)
      }
    if (!is.list(label_list)) {
        rlang::abort("`label_list` should be a list of named list(s).")
    }
    if (is.null(semPaths_plot)) {
        rlang::abort("semPaths_plot not specified.")
      } else {
        if (!inherits(semPaths_plot, "qgraph")) {
            rlang::abort("semPaths_plot is not a qgraph object.")
          }
      }
    if (!missing(label.cex)) {
        if (!is.numeric(label.cex)) {
            rlang::abort("label.cex must be a single number.")
          }
      }
    if (!missing(label.scale)) {
        if (!is.logical(label.scale)) {
            rlang::abort("label.scale must be logical.")
          }
        if (is.na(label.scale)) {
            rlang::abort("label.scale must be TRUE or FALSE.")
          }
      }
    if (!missing(label.prop)) {
        if (!is.numeric(label.prop)) {
            rlang::abort("label.prop must be numeric.")
          }
      }
    if (!missing(label.norm)) {
        if (!is.character(label.norm)) {
            rlang::abort("label.norm must be a string.")
          }
      }
    Nodes_names <- semPaths_plot$graphAttributes$Nodes$names
    Nodes_labels <- semPaths_plot$graphAttributes$Nodes$labels

    if (!is.list(Nodes_names)) {
        Nodes_names <- as.list(Nodes_names)
      }
    if (!is.list(Nodes_labels)) {
        Nodes_labels <- as.list(Nodes_labels)
      }

    # Convert a named list to a list of named list
    if (!all(sapply(label_list, is.list))) {
        label_list_org <- label_list
        tmpfct <- function(x, y) {
            list(node = x, to = y)
          }
        label_list <- mapply(tmpfct,
                             names(label_list),
                             label_list,
                             SIMPLIFY = FALSE,
                             USE.NAMES = FALSE)
      }
    to_in <- sapply(label_list, function(x) x$to)

    # TO CHECK: Which one to work on? Nodes$names or Nodes$labels?
    Nodes_in <- sapply(label_list, function(x) x$node)
    check_match_labels(Nodes_in, Nodes_labels)
    check_match_labels(Nodes_in, Nodes_names)
    # Nodes_labels_old <- Nodes_labels
    # for (i in label_list) {
    #     Nodes_labels[Nodes_labels == i$nod] <- i$to
    #     Nodes_names[Nodes_names == i$nod] <- i$to
    # }

    # Use Mark's approach
    Nodes_labels_old <- Nodes_labels
    Nodes_pos_tochange <- match(Nodes_in, Nodes_labels)
    Nodes_labels[Nodes_pos_tochange] <- to_in
    Nodes_names_old <- Nodes_names
    Nodes_pos_tochange <- match(Nodes_in, Nodes_names)
    Nodes_names[Nodes_pos_tochange] <- to_in

    # TO CHECK: Should Nodes$names and the names of the list be updated?
    # Also change the node names to match the behavior of semPlot::semPaths()

    # Add names to Nodes_labels and Nodes_names
    if (is.null(names(Nodes_labels))) {
       names(Nodes_labels) <- Nodes_labels_old
    }
    semPaths_plot$graphAttributes$Nodes$labels <- Nodes_labels
    if (is.null(names(Nodes_names))) {
       names(Nodes_names) <- Nodes_names_old
    }
    semPaths_plot$graphAttributes$Nodes$names <- Nodes_names

    if (!missing(label.cex)) {
        semPaths_plot$graphAttributes$Nodes$label.cex <- label.cex
      }
    if (!missing(label.scale)) {
        semPaths_plot$plotOptions$label.scale <- label.scale
      }
    if (!missing(label.prop)) {
        semPaths_plot$plotOptions$label.prop <- label.prop
      }
    if (!missing(label.norm)) {
        semPaths_plot$plotOptions$label.norm <- label.norm
      }

    semPaths_plot
  }

# \code{change_node_label2()} is an experimental version that takes a
# named list as input.
# SF (2023-10-15): This function is not exported and so no need to document it.
#' @noRd

change_node_label2 <- function(semPaths_plot, label_list = NULL) {
  if (is.null(label_list)) {
    rlang::abort("label_list not specified.")
  }
  if (is.null(semPaths_plot)) {
    rlang::abort("semPaths_plot not specified.")
  } else {
    if (!inherits(semPaths_plot, "qgraph")) {
      rlang::abort("semPaths_plot is not a qgraph object.")
    }
  }
  Nodes_names <- semPaths_plot$graphAttributes$Nodes$names
  Nodes_labels <- semPaths_plot$graphAttributes$Nodes$labels

  if (!is.list(Nodes_names)) {
    Nodes_names <- as.list(Nodes_names)
  }
  if (!is.list(Nodes_labels)) {
    Nodes_labels <- as.list(Nodes_labels)
  }

  check_match_labels(names(label_list), Nodes_labels)
  check_match_labels(names(label_list), Nodes_names)

  Nodes_labels_old <- Nodes_labels
  Nodes_pos_tochange <- match(names(label_list), Nodes_labels)
  Nodes_labels[Nodes_pos_tochange] <- label_list
  Nodes_pos_tochange <- match(names(label_list), Nodes_names)
  Nodes_names[Nodes_pos_tochange] <- label_list

  semPaths_plot$graphAttributes$Nodes$labels <- Nodes_labels
  semPaths_plot$graphAttributes$Nodes$names <- Nodes_names
  semPaths_plot
}