R/safe_edge_label_positions.R

In semptools: Customizing Structural Equation Modelling Plots

#' @title Adjust Edge Label Positions to
#' Avoid Overlapping Labels
#'
#' @description Move the edge labels
#' away from path intersections.
#'
#' @details
#' This function identify all intersection
#' points between two paths in a model,
#' and set the position of an edge
#' label to the mid-point of a line segment
#' between an intersection point and
#' the another intersection point or
#' the origin/destination of a path.
#'
#' This function is intended for having
#' a "likely" readable graph with as
#' little user-intervention as possible.
#' If precise control of the edge label
#' positions is desired, use
#' [set_edge_label_position()].
#'
#'
#' @return
#' If `object` is a `lavaan`-class
#' object, it returns
#' a named numeric vector of edge
#' positions to be used by
#' [set_edge_label_position()].
#' If `object` is a `qgraph` object
#' and `update_plot` is `TRUE`, it
#' returns a `qgraph` object with the
#' adjusted edge label positions.
#' Otherwise, it returns a named vector
#' of the position to be adjusted, as
#' for a `lavaan`-class object.
#'
#'
#' @param object It can be the output of
#' [lavaan::sem()] or
#' [lavaan::lavaan()], or a
#' `lavaan`-class object. The model must
#' have a `beta` matrix of the
#' structural path. It can also be a
#' `qgraph` object generated by
#' [semPlot::semPaths()].
#'
#' @param layout A layout matrix.
#' Required if `object` is a
#' `lavaan`-class object. Ignored if
#' `object` is a `qgraph` object.
#'
#' @param default_pos Used if `object`
#' is a `lavaan`-class object. The
#' default position of an edge label.
#' If this position is "safe" (not
#' on the intersection between paths),
#' it will be used. Ignored if `
#' object` is a `qgraph` object.
#'
#' @param tolerance If the distance
#' between a position and an intersection
#' is greater than this distance, then
#' a position is considered safe and
#' will not be adjusted.
#'
#' @param update_plot Logical. Used on
#' if `object` is a `qgraph` object. If
#' `TRUE`, the function returns a
#' modified `qgraph` object. If `FALSE`,
#' the function returns a named vector
#' of the new positions.
#'
#' @seealso [set_edge_label_position()]
#' on setting the positions of edge
#' labels.
#'
#' @examples
#'
#' library(lavaan)
#' library(semPlot)
#' # Create a dummy dataset
#' mod_pa <-
#' "
#' m11 ~ c1 + x1
#' m12 ~ c2 + m11 + m21
#' m21 ~ c1 + x1
#' m22 ~ c1 + m21 + m11
#' y ~ m12 + m22 + x1
#' "
#' fit <- lavaan::sem(
#'           mod_pa,
#'           do.fit = FALSE
#'         )
#' dat <- simulateData(
#'           parameterTable(fit),
#'           sample.nobs = 500,
#'           seed = 1234
#'         )
#' fit <- lavaan::sem(
#'           mod_pa,
#'           dat
#'         )
#' # Set the layout
#' m <- auto_layout_mediation(
#'         fit,
#'         exclude = c("c1", "c2", "c3")
#'       )
#' pos_new <- safe_edge_label_position(
#'                 fit,
#'                 layout = m
#'               )
#' pos_new
#' pm <- semPlotModel(fit) |> drop_nodes(c("c1", "c2"))
#' p <- semPaths(
#'           pm,
#'           whatLabels = "est",
#'           layout = m,
#'           DoNotPlot = TRUE
#'         )
#' # Three labels overlap with each other
#' plot(p)
#' # Update the plot
#' p_safe <- p |> safe_edge_label_position()
#' # Three labels do not overlap in this plot
#' plot(p_safe)
#' # Set the position manually
#' p_safe2 <- p |>
#'             set_edge_label_position(pos_new)
#' plot(p_safe2)
#'
#'
#' @export
safe_edge_label_position <- function(
                              object,
                              layout = NULL,
                              default_pos = .5,
                              tolerance = .05,
                              update_plot = TRUE
                            ) {

  object_type <- NA
  if (inherits(object, "lavaan")) {
    object_type <- "lavaan"
    if (lavaan::lavTech(object, "ngroups") != 1) {
      stop("Multigroup models not supported.")
    }
    beta0 <- lavaan::lavInspect(
                object,
                what = "free"
              )$beta
    if (is.null(beta0)) {
      stop("The model has no structural paths. Is it a CFA model?")
    }
    mxy <- layout_to_layoutxy(layout)
  } else if (inherits(object, "qgraph")) {
    object_type <- "qgraph"
    beta0 <- qgraph_to_beta(object)
    mxy <- qgraph_to_layoutxy(object)
  } else {
    stop("object is not a supported type.")
  }

  vnames <- rownames(mxy)
  beta1 <- beta0[vnames, vnames, drop = FALSE]

  m_paths <- all_paths(
                beta = beta1,
                m = mxy
              )
  m_intersect <- intersect_matrix(m_paths)
  m0 <- split(m_intersect,
              seq_len(nrow(m_intersect)))
  names(m0) <- rownames(m_intersect)

  if (object_type == "lavaan") {
    default_pos1 <- rep(default_pos, length(m0))
  } else if (object_type == "qgraph") {
    e_pos <- qgraph_to_edge_label_positions(object)
    default_pos1 <- sapply(
                      m_paths,
                      function(x) {
                        e_pos[x$to, x$from]
                      })
    names(default_pos1) <- names(m0)
  }

  out <- mapply(
            safe_edge_label_position_i,
            x = m0,
            default_pos = default_pos1,
            MoreArgs = list(
                          tolerance = tolerance
                        ),
            SIMPLIFY = TRUE,
            USE.NAMES = TRUE)

  out <- out[out != default_pos]

  if (object_type == "qgraph") {
    if (update_plot) {
      if (length(out) > 0) {
        out <- set_edge_label_position(
                  semPaths_plot = object,
                  position_list = out
                )
      } else {
        out <- object
      }
    }
  }
  out
}

#' @noRd
safe_edge_label_position_i <- function(
                      x,
                      default_pos = .5,
                      tolerance = .1
                    ) {
  if (all(is.na(x))) {
    return(default_pos)
  }
  x <- x[!is.na(x)]
  x <- sort(x)
  if (min(abs(default_pos - x)) > tolerance) {
    return(default_pos)
  }
  x0 <- c(tolerance, x, 1 - tolerance)
  x1 <- diff(x0)
  i <- which.max(x1)
  out <- mean(x0[c(i, i + 1)])
  out
}