R/set_cfa_layout.R

In semptools: Customizing Structural Equation Modelling Plots

#'@title Configure the layout of factors of a CFA graph by semPaths
#'
#'@description Configure the layout of factors and adjust other
#' aspects of a CFA graph by semPaths.
#'
#'@details Modify a [qgraph::qgraph] object generated by semPaths
#' based on a confirmatory factor analysis model.
#'
#'@return A [qgraph::qgraph] based on the original one, with various
#' aspects of the model modified.
#'
#'@param semPaths_plot A [qgraph::qgraph] object generated by
#' semPaths, or a similar qgraph object modified by other [semptools]
#' functions.
#'
#'@param indicator_order A string vector of the indicators. The order
#' of the names is the order of the indicators in the graph, when they
#' are drawn on the bottom of the graph. The indicators should be
#' grouped by the factors on which they load on. For example, if x1,
#' x2, x4 load on f2, and x3, x5, x6 load on f1, then vector should be
#' either c("x1", "x2", "x4", "x3", "x5", "x6") or c("x3", "x5", "x6",
#' "x1", "x2", "x4"). Indicators within a group can be ordered in any
#' way. If it is a named vector, its names will be used for the
#' argument `indicator_factor`. If it is `NULL` (default),
#' [auto_indicator_order()] will be called to determine the
#' indicator order automatically.
#'
#'@param indicator_factor A string vector of the same length of the
#' indicator order, storing the name of the factor for which each of
#' the indicator in indicator_factor loads on. For example, if x1, x2,
#' x4 load on f2, and x3, x5, x6 load on f1, and indicator_order is
#' c("x3", "x5", "x6", "x1", "x2", "x4"), then indicator_factor should
#' be c("f2", "f2", "f2", "f1", "f1", "f1"). If `NULL`
#' (default) and `indicator_order` is a named vector (supplied
#' by users or generated by [auto_indicator_order()]), then
#' it will be set to the names of `indicator_order`.
#'
#'@param fcov_curve A number used to set the curvature of the
#' inter-factor covariances. Default is .4.
#'
#'@param loading_position The positions of all factor loadings.
#' Default is .5, on the middle of the arrows. Larger the number,
#' closer the loadings to the indicators. Smaller the number, closer
#' the loadings to the factors.
#'
#'@param point_to Can be "down", "left", "up", or "right". Specify the
#' direction that the factors "point" to the indicators. Default is
#' "down".
#'
#'@examples
#'library(lavaan)
#'library(semPlot)
#'mod <-
#'  'f1 =~ x01 + x02 + x03
#'   f2 =~ x04 + x05 + x06 + x07
#'   f3 =~ x08 + x09 + x10
#'   f4 =~ x11 + x12 + x13 + x14
#'  '
#'fit_cfa <- lavaan::sem(mod, cfa_example)
#'lavaan::parameterEstimates(fit_cfa)[, c("lhs", "op", "rhs", "est", "pvalue")]
#'p <- semPaths(fit_cfa, whatLabels="est",
#'        sizeMan = 2.5,
#'        nCharNodes = 0, nCharEdges = 0,
#'        edge.width = 0.8, node.width = 0.7,
#'        edge.label.cex = 0.6,
#'        style = "ram",
#'        mar = c(10,10,10,10))
#'indicator_order  <- c("x04", "x05", "x06", "x07", "x01", "x02", "x03", "x11",
#'                       "x12", "x13", "x14", "x08", "x09", "x10")
#'indicator_factor <- c( "f2",  "f2",  "f2",  "f2",  "f1",  "f1",  "f1",  "f4",
#'                       "f4",  "f4",  "f4",  "f3",  "f3",  "f3")
#'p2 <- set_cfa_layout(p, indicator_order,
#'                          indicator_factor,
#'                          fcov_curve = 1.5,
#'                          loading_position = .8)
#'plot(p2)
#'
#'# Use a named vector for indicator_order
#'indicator_order2 <- c(f2 = "x04", f2 = "x05", f2 = "x06", f2 = "x07",
#'                      f1 = "x01", f1 = "x02", f1 = "x03",
#'                      f4 = "x11", f4 = "x12", f4 = "x13", f4 = "x14",
#'                      f3 = "x08", f3 = "x09", f3 = "x10")
#'p2 <- set_cfa_layout(p,
#'                     indicator_order = indicator_order2,
#'                     fcov_curve = 1.5,
#'                     loading_position = .8)
#'plot(p2)
#'
#'# Use automatically generated indicator_order and indicator_factor
#'p2 <- set_cfa_layout(p,
#'                     fcov_curve = 1.5,
#'                     loading_position = .8)
#'plot(p2)
#'
#'p2 <- set_cfa_layout(p, indicator_order,
#'                          indicator_factor,
#'                          fcov_curve = 1.5,
#'                          loading_position = .8,
#'                          point_to = "left")
#'plot(p2)
#'p2 <- set_cfa_layout(p, indicator_order,
#'                          indicator_factor,
#'                          fcov_curve = 1.5,
#'                          loading_position = .8,
#'                          point_to = "up")
#'plot(p2)
#'p2 <- set_cfa_layout(p, indicator_order,
#'                          indicator_factor,
#'                          fcov_curve = 1.5,
#'                          loading_position = .8,
#'                          point_to = "right")
#'plot(p2)
#'
#' @export

set_cfa_layout <- function(semPaths_plot,
                             indicator_order = NULL,
                             indicator_factor = NULL,
                             fcov_curve = .4,
                             loading_position = .5,
                             point_to = "down") {
    if (is.null(indicator_order)) {
        check_node_label_string(semPaths_plot$graphAttributes$Nodes$labels)
        indicator_order <- auto_indicator_order(semPaths_plot)
        # stop("indicator_order not specified.")
      }
    if (is.null(indicator_factor)) {
        if (!is.null(names(indicator_order))) {
            indicator_factor <- names(indicator_order)
          } else {
            indicator_order <- tryCatch(lavaan_indicator_order(indicator_order),
                                         error = function(e) e)
            if (inherits(indicator_factor, "error")) {
                stop("indicator_factor not specified or cannot be determined.")
              }
            indicator_factor <- names(indicator_order)
          }
      }
    if (is.null(semPaths_plot)) {
        stop("semPaths_plot not specified.")
      } else {
        if (!inherits(semPaths_plot, "qgraph")) {
            stop("semPaths_plot is not a qgraph object.")
          }
      }
    if ("triangle" %in% semPaths_plot$graphAttributes$Nodes$shape) {
      rlang::abort(paste("The semPaths plot seems to have one or",
                        "more intercepts. Models with intercepts",
                        "are not supported yet. Consider setting",
                        "'intercepts = FALSE' in semPaths."))
    }
    if (!is.numeric(fcov_curve) | length(fcov_curve) > 1) {
        stop("fcov_curve is not a single number.")
      }
    if (!is.numeric(loading_position) | length(loading_position) > 1) {
        stop("loading_position is not a single number.")
      }

    Nodes_names <- semPaths_plot$graphAttributes$Nodes$names
    if (!is.null(names(Nodes_names))) {
      Nodes_names <- names(Nodes_names)
      Nodes_names2 <- semPaths_plot$graphAttributes$Nodes$names
    }

    if (!all(Nodes_names[semPaths_plot$Edgelist$to[!semPaths_plot$Edgelist$bidirectional]]
             %in% indicator_order)) {
        if (!all(Nodes_names2[semPaths_plot$Edgelist$to[!semPaths_plot$Edgelist$bidirectional]]
              %in% indicator_order)) {
            msg_tmp <- setdiff(Nodes_names2[semPaths_plot$Edgelist$to[!semPaths_plot$Edgelist$bidirectional]],
                               indicator_order)
            msg_tmp <- paste(msg_tmp,
                             collapse = ", ")
            warning("One or more indicators in the graph are not in indicator_order. Unexpected results may occur. ",
                    "Indicator(s) involved: ",
                    msg_tmp)
          } else {
            tmp <- sapply(indicator_order, function(x) {
                Nodes_names[match(x, Nodes_names2)]
              }, USE.NAMES = FALSE)
            indicator_order <- tmp
          }
      }
    # Exclude residuals in LISREL style plots
    tmp <- !semPaths_plot$Edgelist$bidirectional &
            (semPaths_plot$Edgelist$from != semPaths_plot$Edgelist$to)
    if (!all(Nodes_names[semPaths_plot$Edgelist$from[tmp]]
             %in% indicator_factor)) {
        if (!all(Nodes_names2[semPaths_plot$Edgelist$from[tmp]]
             %in% indicator_factor)) {
            warning("One or more factors in the graph are not in indicator_factor. Unexpected results may occur.")
          } else {
            tmp <- sapply(indicator_factor, function(x) {
                Nodes_names[match(x, Nodes_names2)]
              }, USE.NAMES = FALSE)
            indicator_factor <- tmp
          }
      }

    point_to <- tolower(point_to)
    if (!(point_to %in% c("down", "up", "left", "right"))) {
        stop("point_to must be 'down', 'up', 'left', or 'right'.")
      }
    indicator_position <- seq(-1, 1, length.out = length(indicator_order))
    names(indicator_position) <- indicator_order
    factor_position <- tapply(indicator_position, indicator_factor, mean)
    factor_order <- unique(indicator_factor)
    Nodes_position <- c(indicator_position, factor_position)

    original_layout <- semPaths_plot$layout
    i <- match(Nodes_names, names(Nodes_position))
    new_layout <- original_layout
    new_layout[, 1] <- Nodes_position[i]
    new_layout
    semPaths_plot$layout <- new_layout

    if (point_to == "down") {
        semPaths_plot$layout <- new_layout %*% matrix(c( 1,  0,  0,  1), 2, 2)
      } else if (point_to == "left") {
        semPaths_plot$layout <- new_layout %*% matrix(c( 0,  1, -1,  0), 2, 2)
        rotate_resid_list <- lapply(factor_order,
              function(x) list(node = x, rotate = 90))
        semPaths_plot <- rotate_resid(semPaths_plot, rotate_resid_list)
        rotate_resid_list_indicator <- lapply(indicator_order,
              function(x) list(node = x, rotate = -90))
        semPaths_plot <- rotate_resid(semPaths_plot, rotate_resid_list_indicator)
      } else if (point_to == "up") {
        semPaths_plot$layout <- new_layout %*% matrix(c(-1,  0,  0, -1), 2, 2)
        rotate_resid_list <- lapply(factor_order,
              function(x) list(node = x, rotate = 180))
        semPaths_plot <- rotate_resid(semPaths_plot, rotate_resid_list)
        rotate_resid_list_indicator <- lapply(indicator_order,
              function(x) list(node = x, rotate =   0))
        semPaths_plot <- rotate_resid(semPaths_plot, rotate_resid_list_indicator)
      } else if (point_to == "right") {
        semPaths_plot$layout <- new_layout %*% matrix(c( 0, -1,  1,  0), 2, 2)
        rotate_resid_list <- lapply(factor_order,
              function(x) list(node = x, rotate = -90))
        semPaths_plot <- rotate_resid(semPaths_plot, rotate_resid_list)
        rotate_resid_list_indicator <- lapply(indicator_order,
              function(x) list(node = x, rotate =  90))
        semPaths_plot <- rotate_resid(semPaths_plot, rotate_resid_list_indicator)
      }

    # Fix the factor covariance

    k <- length(factor_order)
    kstar <- k*(k - 1)/2
    fcov <- data.frame(lhs = rep(NA, kstar),
                       rhs = rep(NA, kstar),
                       level = rep(NA, kstar))
    m <- 0

    # Set inter-factor covariances

    if (k > 1) {
      for (i in seq(2, k)) {
         for (j in seq(i - 1)) {
             m <- m + 1
             fcov$lhs[m] <- factor_order[i]
             fcov$rhs[m] <- factor_order[j]
             fcov$level[m] <- i - j
           }
         }
      fcov$curve <- fcov$level * fcov_curve
      curve_old <- semPaths_plot$graphAttributes$Edges$curve
      curve_new <- curve_old
      curve_index <- mapply(edge_index, from = fcov$lhs,
                                          to = fcov$rhs,
                                         MoreArgs =
                                           list(semPaths_plot = semPaths_plot))
      curve_index <- curve_index[!is.na(curve_index)]
      if (length(curve_index) > 0) {
          curve_new[curve_index] <- -1*fcov$curve
        }
      curve_index <- mapply(edge_index, from = fcov$rhs,
                                          to = fcov$lhs,
                                         MoreArgs =
                                           list(semPaths_plot = semPaths_plot))
      curve_index <- curve_index[!is.na(curve_index)]
      if (length(curve_index) > 0) {
          curve_new[curve_index] <- fcov$curve
        }
      semPaths_plot$graphAttributes$Edges$curve <- curve_new
      }

    # Set loading position

    loading_position_list <-
        (Nodes_names[semPaths_plot$Edgelist$from] %in% factor_order) &
        (Nodes_names[semPaths_plot$Edgelist$from] %in% factor_order) &
                     !semPaths_plot$Edgelist$bidirectional
    semPaths_plot$graphAttributes$Edges$edge.label.position[loading_position_list] <- loading_position
    semPaths_plot
  }