R/add_rsq.R

In semptools: Customizing Structural Equation Modelling Plots

#'@title Add R-Squares to Endogenous Variables
#'
#'@description Replace the residual variances of exogenous
#' variables by their R-squares in a [qgraph::qgraph] object.
#'
#'@details Modify a [qgraph::qgraph] object generated by
#'   \code{\link[semPlot]{semPaths}} by setting the labels
#'   of the residuals of endogenous variables to their
#'   R-squares.
#'
#'   Require either the original object used in the semPaths call,
#'   or a data frame with the R-square for each endogenous
#'   variable.
#'
#'Currently supports only plots based on \code{\link[lavaan]{lavaan}}
#'output.
#'
#'@return If the input is a [qgraph::qgraph] object, the function
#'  returns a qgraph based on the original one, with R-squares
#'  added. If the input is a list of qgraph objects, the
#'  function returns a list of the same length.
#'
#'@param semPaths_plot A qgraph object generated by
#'   \code{\link[semPlot]{semPaths}}, or a similar qgraph object
#'   modified by other [semptools] functions.
#'
#'@param object The object used by semPaths to generate the plot. Use
#'   the same argument name used in \code{\link[semPlot]{semPaths}} to
#'   make the meaning of this argument obvious. Currently only object
#'   of class `lavaan` is supported.
#'
#'@param digits Integer indicating number of decimal places for the
#'   R-squares. Default is 2L.
#'
#'@param ests A data.frame from the
#'   \code{\link[lavaan]{parameterEstimates}} function, or
#'   from other function with these columns:? `lhs`, `op`,
#'   `rhs`, and `est`. The rows with `op` equal to `r2`
#'   are used to find the R-squares. Only used when
#'   \code{object} is not specified.
#'
#'@param rsq_string The string before the
#'   R-squares. Default is `"R2="`.
#'
#'@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", "se")]
#'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)
#'p_pa2 <- add_rsq(p_pa, fit_pa)
#'plot(p_pa2)
#'
#'mod_cfa <-
#'  'f1 =~ x01 + x02 + x03
#'   f2 =~ x04 + x05 + x06 + x07
#'   f3 =~ x08 + x09 + x10
#'   f4 =~ x11 + x12 + x13 + x14
#'  '
#'fit_cfa <- lavaan::sem(mod_cfa, cfa_example)
#'lavaan::parameterEstimates(fit_cfa)[ , c("lhs", "op", "rhs",
#'                                         "est", "pvalue", "se")]
#'p_cfa <- semPlot::semPaths(fit_cfa, whatLabels = "est",
#'                           style = "ram",
#'                           nCharNodes = 0, nCharEdges = 0)
#'# Place standard errors on a new line
#'p_cfa2 <- add_rsq(p_cfa, fit_cfa)
#'plot(p_cfa2)
#'
#'mod_sem <-
#' 'f1 =~ x01 + x02 + x03
#'  f2 =~ x04 + x05 + x06 + x07
#'  f3 =~ x08 + x09 + x10
#'  f4 =~ x11 + x12 + x13 + x14
#'  f3 ~  f1 + f2
#'  f4 ~  f1 + f3
#' '
#'
#'# Can be used with mark_se() and mark_sig()
#'fit_sem <- lavaan::sem(mod_sem, sem_example)
#'lavaan::parameterEstimates(fit_sem)[ , c("lhs", "op", "rhs",
#'                                         "est", "pvalue", "se")]
#'p_sem <- semPlot::semPaths(fit_sem, whatLabels = "est",
#'                           style = "ram",
#'                           nCharNodes = 0, nCharEdges = 0)
#'# Mark significance, and then add standard errors
#'p_sem2 <- mark_sig(p_sem, fit_sem)
#'p_sem3 <- mark_se(p_sem2, fit_sem, sep = "\n")
#'p_sem4 <- add_rsq(p_sem3, fit_sem)
#'plot(p_sem4)
#'
#'@importFrom rlang .data
#'@export

add_rsq <- function(semPaths_plot,
                    object,
                    digits = 2L,
                    rsq_string = "R2=",
                    ests = NULL) {
  if (is.null(ests)) {
    ests <- lavaan::parameterEstimates(object, se = FALSE, ci = FALSE,
                                       zstat = FALSE, pvalue = FALSE,
                                       rsquare = TRUE)
  }
  ests <- ests[ests$op == "r2", ]
  if (nrow(ests) == 0) {
    # No R-square
    return(semPaths_plot)
  }
  if (inherits(semPaths_plot, "list")) {
    if (length(semPaths_plot) != length(unique(ests$group))) {
      rlang::abort(paste("length of qgraph list does not match",
                         "number of groups in model fit object."))
    }
    ests_list <- split(ests, ests$group)
    mapply(add_rsq, semPaths_plot, ests = ests_list, SIMPLIFY = FALSE)
  } else {
    if (!missing(object) && lavaan::lavInspect(object, "ngroups") > 1) {
      rlang::abort(paste("length of qgraph list does not match",
                         "number of groups in model fit object."))
    }
    Nodes_names <- semPaths_plot$graphAttributes$Nodes$names
    if (!is.null(names(Nodes_names))) {
      Nodes_names <- names(Nodes_names)
    }
    if (!all(union(ests$lhs, ests$rhs) %in% Nodes_names)) {
      abort_nomatch(union(ests$lhs, ests$rhs), Nodes_names)
    }
    Edgelist <- data.frame(
      from_names = Nodes_names[semPaths_plot$Edgelist$from],
      to_names   = Nodes_names[semPaths_plot$Edgelist$to],
      semPaths_plot$Edgelist, stringsAsFactors = FALSE)
    graphAttributes_Edges <- data.frame(
      from_names = Nodes_names[semPaths_plot$Edgelist$from],
      to_names   = Nodes_names[semPaths_plot$Edgelist$to],
      semPaths_plot$graphAttributes$Edges, stringsAsFactors = FALSE)
    graphAttributes_Edges$id <- as.numeric(rownames(graphAttributes_Edges))
    edge_labels <- graphAttributes_Edges[, c("id",
                                             "from_names",
                                             "to_names",
                                             "labels")]
    ests_to_add <- ests[, c("lhs", "rhs", "est")]
    ests_to_add_tmp <- ests_to_add
    colnames(ests_to_add_tmp) <- gsub("\\<rhs\\>",
                                   "from_names",
                                   colnames(ests_to_add_tmp))
    colnames(ests_to_add_tmp) <- gsub("\\<lhs\\>",
                                   "to_names",
                                   colnames(ests_to_add_tmp))
    edge_to_add <- merge(x = edge_labels,
                         y = ests_to_add_tmp,
                         by = c("from_names",
                                "to_names"),
                         all.x = TRUE,
                         sort = FALSE)
    all_na <- apply(edge_to_add[, c("est"), drop = FALSE],
                    MARGIN = 1,
                    FUN = function(x) all(is.na(x)))
    edge_to_add$est <- suppressWarnings(
                      apply(edge_to_add[, c("est"), drop = FALSE],
                            MARGIN = 1,
                            FUN = max,
                            na.rm = TRUE))
    edge_to_add$est[all_na] <- NA
    edge_to_add[!all_na, "labels"] <- paste0(rsq_string,
                                             formatC(edge_to_add[!all_na, "est"],
                                                     digits = digits,
                                                     format = "f"))
    edge_to_add <- edge_to_add[order(edge_to_add$id), ]
    semPaths_plot$graphAttributes$Edges$labels <- edge_to_add$labels
    semPaths_plot
  }
}