R/mark_se.R
In sfcheung/semptools: Customizing Structural Equation Modelling Plots
Defines functions
mark_se
Documented in
mark_se
#'@title Add Standard Error Estimates to Parameter Estimates (Edge
#' Labels)
#'
#'@description Add standard error estimates, in parentheses, to
#' parameter estimates (edge labels) in a [qgraph::qgraph] object.
#'
#'@details Modify a [qgraph::qgraph] object generated by
#' \code{\link[semPlot]{semPaths}} (currently in parentheses) to the
#' labels. Require either the original object used in the semPaths call,
#' or a data frame with the standard error for each parameter. The latter
#' option is for standard errors not computed by lavaan but by
#' other functions.
#'
#'Currently supports only plots based on \code{\link[lavaan]{lavaan}}
#'output.
#'
#'This function is a variant of, and can be combined with, the
#' \code{\link{mark_sig}} function.
#'
#'@return If the input is a [qgraph::qgraph] object, the function
#' returns a qgraph based on the original one, with standard error
#' estimates appended. 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 sep A character string to separate the coefficient and the
#' standard error (in parentheses). Default to " " (one space). Use
#' \code{"\n"} to enforce a line break.
#'
#'@param digits Integer indicating number of decimal places for the
#' appended standard errors. 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 `se`. Only used when
#' \code{object} is not specified.
#'
#'@param std_type If standardized solution is used in the plot,
#' set this either to the type of standardization (e.g., `"std.all"`)
#' or to `TRUE`. It will be passed to [lavaan::standardizedSolution()]
#' to compute the standard errors for the standardized solution.
#' Used only if standard errors are not supplied directly
#' through `ests`.
#'
#'@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 <- mark_se(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 <- mark_se(p_cfa, fit_cfa, sep = "\n")
#'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
#' '
#'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")
#'plot(p_sem3)
#'
#'@importFrom rlang .data
#'@export
mark_se <- function(semPaths_plot, object, sep = " ", digits = 2L,
ests = NULL,
std_type = FALSE) {
if ("triangle" %in% semPaths_plot$graphAttributes$Nodes$shape) {
rlang::inform(paste("The semPaths plot seems to have one or",
"more intercepts. Support for models with",
"are only experimental. If failed,",
"consider setting",
"'intercepts = FALSE' in semPaths."))
}
if (is.null(ests)) {
if (isFALSE(std_type)) {
ests <- lavaan::parameterEstimates(object, se = TRUE, ci = FALSE,
zstat = FALSE, pvalue = FALSE)
} else {
if (isTRUE(std_type)) std_type <- "std.all"
ests <- lavaan::standardizedSolution(object, type = std_type,
se = TRUE, ci = FALSE,
zstat = FALSE, pvalue = FALSE)
}
}
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(mark_se, 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)
}
ests$rhs <- ifelse(ests$op == "~1", yes = "1", no = ests$rhs)
if (!all(Nodes_names %in% union(ests$lhs, ests$rhs))) {
abort_nomatch(Nodes_names, union(ests$lhs, ests$rhs))
}
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")]
# Remove thresholds. Not used
to_keep <- ests$op != "|"
# Remove ~*~. Not used.
to_keep <- to_keep & (ests$op != "~*~")
ests_ses <- ests[to_keep, c("lhs", "rhs", "se")]
ests_ses_rev <- ests_ses
colnames(ests_ses_rev) <- gsub("\\<se\\>",
"se_rev",
colnames(ests_ses_rev))
ests_ses_tmp <- ests_ses
colnames(ests_ses_tmp) <- gsub("\\<rhs\\>",
"from_names",
colnames(ests_ses_tmp))
colnames(ests_ses_tmp) <- gsub("\\<lhs\\>",
"to_names",
colnames(ests_ses_tmp))
ests_ses_rev_tmp <- ests_ses_rev
colnames(ests_ses_rev_tmp) <- gsub("\\<rhs\\>",
"to_names",
colnames(ests_ses_rev_tmp))
colnames(ests_ses_rev_tmp) <- gsub("\\<lhs\\>",
"from_names",
colnames(ests_ses_rev_tmp))
edge_ses <- merge(x = edge_labels,
y = ests_ses_tmp,
by = c("from_names",
"to_names"),
all.x = TRUE,
all.y = FALSE,
sort = FALSE)
edge_ses <- merge(x = edge_ses,
y = ests_ses_rev_tmp,
by = c("from_names",
"to_names"),
all.x = TRUE,
all.y = FALSE,
sort = FALSE)
all_na <- apply(edge_ses[, c("se", "se_rev")],
MARGIN = 1,
FUN = function(x) all(is.na(x)))
edge_ses$se <- suppressWarnings(
apply(edge_ses[, c("se", "se_rev")],
MARGIN = 1,
FUN = max,
na.rm = TRUE))
edge_ses$se[all_na] <- NA
edge_ses <- edge_ses[order(edge_ses$id), ]
labels_old <- semPaths_plot$graphAttributes$Edges$labels
labels_new <- paste0(labels_old, sep,
"(", formatC(edge_ses$se, digits, format = "f"), ")")
semPaths_plot$graphAttributes$Edges$labels <- labels_new
semPaths_plot
}
}
sfcheung/semptools documentation built on Jan. 16, 2025, 3:09 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions mark_se
Documented in mark_se
#'@title Add Standard Error Estimates to Parameter Estimates (Edge
#' Labels)
#'
#'@description Add standard error estimates, in parentheses, to
#' parameter estimates (edge labels) in a [qgraph::qgraph] object.
#'
#'@details Modify a [qgraph::qgraph] object generated by
#' \code{\link[semPlot]{semPaths}} (currently in parentheses) to the
#' labels. Require either the original object used in the semPaths call,
#' or a data frame with the standard error for each parameter. The latter
#' option is for standard errors not computed by lavaan but by
#' other functions.
#'
#'Currently supports only plots based on \code{\link[lavaan]{lavaan}}
#'output.
#'
#'This function is a variant of, and can be combined with, the
#' \code{\link{mark_sig}} function.
#'
#'@return If the input is a [qgraph::qgraph] object, the function
#' returns a qgraph based on the original one, with standard error
#' estimates appended. 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 sep A character string to separate the coefficient and the
#' standard error (in parentheses). Default to " " (one space). Use
#' \code{"\n"} to enforce a line break.
#'
#'@param digits Integer indicating number of decimal places for the
#' appended standard errors. 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 `se`. Only used when
#' \code{object} is not specified.
#'
#'@param std_type If standardized solution is used in the plot,
#' set this either to the type of standardization (e.g., `"std.all"`)
#' or to `TRUE`. It will be passed to [lavaan::standardizedSolution()]
#' to compute the standard errors for the standardized solution.
#' Used only if standard errors are not supplied directly
#' through `ests`.
#'
#'@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 <- mark_se(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 <- mark_se(p_cfa, fit_cfa, sep = "\n")
#'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
#' '
#'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")
#'plot(p_sem3)
#'
#'@importFrom rlang .data
#'@export
mark_se <- function(semPaths_plot, object, sep = " ", digits = 2L,
ests = NULL,
std_type = FALSE) {
if ("triangle" %in% semPaths_plot$graphAttributes$Nodes$shape) {
rlang::inform(paste("The semPaths plot seems to have one or",
"more intercepts. Support for models with",
"are only experimental. If failed,",
"consider setting",
"'intercepts = FALSE' in semPaths."))
}
if (is.null(ests)) {
if (isFALSE(std_type)) {
ests <- lavaan::parameterEstimates(object, se = TRUE, ci = FALSE,
zstat = FALSE, pvalue = FALSE)
} else {
if (isTRUE(std_type)) std_type <- "std.all"
ests <- lavaan::standardizedSolution(object, type = std_type,
se = TRUE, ci = FALSE,
zstat = FALSE, pvalue = FALSE)
}
}
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(mark_se, 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)
}
ests$rhs <- ifelse(ests$op == "~1", yes = "1", no = ests$rhs)
if (!all(Nodes_names %in% union(ests$lhs, ests$rhs))) {
abort_nomatch(Nodes_names, union(ests$lhs, ests$rhs))
}
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")]
# Remove thresholds. Not used
to_keep <- ests$op != "|"
# Remove ~*~. Not used.
to_keep <- to_keep & (ests$op != "~*~")
ests_ses <- ests[to_keep, c("lhs", "rhs", "se")]
ests_ses_rev <- ests_ses
colnames(ests_ses_rev) <- gsub("\\<se\\>",
"se_rev",
colnames(ests_ses_rev))
ests_ses_tmp <- ests_ses
colnames(ests_ses_tmp) <- gsub("\\<rhs\\>",
"from_names",
colnames(ests_ses_tmp))
colnames(ests_ses_tmp) <- gsub("\\<lhs\\>",
"to_names",
colnames(ests_ses_tmp))
ests_ses_rev_tmp <- ests_ses_rev
colnames(ests_ses_rev_tmp) <- gsub("\\<rhs\\>",
"to_names",
colnames(ests_ses_rev_tmp))
colnames(ests_ses_rev_tmp) <- gsub("\\<lhs\\>",
"from_names",
colnames(ests_ses_rev_tmp))
edge_ses <- merge(x = edge_labels,
y = ests_ses_tmp,
by = c("from_names",
"to_names"),
all.x = TRUE,
all.y = FALSE,
sort = FALSE)
edge_ses <- merge(x = edge_ses,
y = ests_ses_rev_tmp,
by = c("from_names",
"to_names"),
all.x = TRUE,
all.y = FALSE,
sort = FALSE)
all_na <- apply(edge_ses[, c("se", "se_rev")],
MARGIN = 1,
FUN = function(x) all(is.na(x)))
edge_ses$se <- suppressWarnings(
apply(edge_ses[, c("se", "se_rev")],
MARGIN = 1,
FUN = max,
na.rm = TRUE))
edge_ses$se[all_na] <- NA
edge_ses <- edge_ses[order(edge_ses$id), ]
labels_old <- semPaths_plot$graphAttributes$Edges$labels
labels_new <- paste0(labels_old, sep,
"(", formatC(edge_ses$se, digits, format = "f"), ")")
semPaths_plot$graphAttributes$Edges$labels <- labels_new
semPaths_plot
}
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.