R/safe_resid_position.R

In semptools: Customizing Structural Equation Modelling Plots

#' @title Adjust Residual Positions
#'
#' @description Rotate the residuals
#' (or R-squares) to avoid overlapping
#' with paths.
#'
#' @details
#' This function identify all directed
#' paths connected to a node, and find
#' the largest arc with no directed
#' paths. The residual (or R-square) is
#' then set to the mid-point of this
#' arc.
#'
#' This function is intended for having
#' a "likely" readable graph with as
#' little user-intervention as possible.
#' If precise control of the positions
#' is desired, use [rotate_resid()].
#'
#' Only directed paths (single-headed
#' arrows) will be considered.
#' Bidirectional paths such as covariances
#' are not taken into account.
#'
#' @return
#' If `object` is a `lavaan`-class
#' object, it returns
#' a named numeric vector of residual
#' angles to be used by
#' [rotate_resid()].
#' If `object` is a `qgraph` object
#' and `update_plot` is `TRUE`, it
#' returns a `qgraph` object with the
#' residuals's angles adjusted.
#' Otherwise, it returns a named vector
#' of the angles, 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_angle Used if `object`
#' is a `lavaan`-class object. The
#' default position of a residual,
#' defined in the same way angle is
#' defined for [rotate_resid()]. Ignored
#' if `object` is a `qgraph` object.
#'
#' @param style The convention for
#' the angles. If `"1200"`, the default,
#' the convention of [rotate_resid()]
#' is used: top (12 o'clock) is 0,
#' clockwise angle is positive and
#' counterclockwise angle is negative.
#' if `"geometry"`, then the convention
#' in geometry is used: right is 0,
#' counterclockwise is positive, and
#' clockwise is negative.
#'
 #' @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 [rotate_resid()]
#' on rotating a residual.
#'
#' @examples
#'
#' library(lavaan)
#' library(semPlot)
#' # Create a dummy dataset
#' mod_pa <-
#' "
#' m11 ~ x1
#' m21 ~ m11
#' m2 ~ m11
#' m22 ~ m11
#' y ~ m2 + m21 + 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
#'       )
#' p <- semPaths(
#'           fit,
#'           whatLabels = "est",
#'           layout = m,
#'           DoNotPlot = TRUE
#'         ) |>
#'       safe_edge_label_position()
#' plot(p)
#' # Update the plot
#' p_safe <- p |> safe_resid_position()
#' plot(p_safe)
#' # Set the positon manually
#' pos_new <- safe_resid_position(p,
#'                                update_plot = FALSE)
#' pos_new
#' p_safe2 <- p |>
#'             rotate_resid(pos_new)
#' plot(p_safe2)
#'
#' @export
safe_resid_position <- function(
                          object,
                          layout,
                          default_angle = 0,
                          style = c("1200", "geometry"),
                          update_plot = TRUE
                        ) {

  style <- match.arg(style)

  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)
    tmp <- rownames(mxy)
    beta0 <- beta0[tmp, tmp]
  } 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.")
  }

  all_paths <- all_paths(
                    beta0,
                    mxy
                  )
  all_angles <- angle_matrix(all_paths)

  resid_pos <- apply(
                  all_angles,
                  MARGIN = 1,
                  FUN = largest_arc
                )
  resid_pos <- resid_pos[!is.na(resid_pos)]
  vnames <- names(resid_pos)

  if (object_type == "lavaan") {
    default_angle1 <- rep(default_angle, length(resid_pos))
  } else if (object_type == "qgraph") {
    n_angle <- qgraph_to_resid_angles(object)
    default_angle1 <- n_angle[vnames]
  }
  if (style == "1200") {
    resid_pos <- 90 - resid_pos
  } else {
    default_angle1 <- default_angle1 + 90
  }
  i <- resid_pos == default_angle1
  resid_pos <- resid_pos[!i]

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