Nothing
# @title Print results of different types of analyses
# @description Takes an object, and prints the results as an 'APA' table.
# @param x Object to be printed
# @param columns Character vector, indicating the columns to retain.
# Default: c("label", "est_sig", "confint").
# @param digits Integet. Number of digits to round to when formatting;
# Default: 2.
# @param ... Other arguments passed to and from other functions.
# @return data.frame
# @rdname table_results
# @export
# table_results <- function(x, columns = c("label",
# "est_sig", "confint"), digits = 2, ...){
# UseMethod("table_results", x)
# }
#' @method table_results rma
#' @export
table_results.rma <- function(x, columns = c("label", "est_sig", "se", "pval", "confint", "group", "level"), digits = 2, format_numeric = TRUE, ...){
results <- do.call(cbind, x[c("b", "se", "zval", "pval", "ci.lb", "ci.ub")])
results <- data.frame(label = rownames(results), results)
names(results)[2] <- c("est")
value_columns <- c("est", "se", "zval", "pval", "ci.lb", "ci.ub")
value_columns <- value_columns[which(value_columns %in%
colnames(results))]
add_cis <- TRUE
results$est_sig <- est_sig(results, digits)
results$confint <- conf_int(results, digits)
if(format_numeric){
results[, value_columns] <- lapply(results[, value_columns],
format_with_na, digits = digits, format = "f")
}
rownames(results) <- NULL
if(!all){
results <- results[, c("b", "se", "zval", "pval", "ci.lb", "ci.ub")]
} else {
results
}
}
# Change which columns table_results reports
#
# Sets a global option to control which columns table_results reports when
# \code{all = FALSE}.
# @param x A character vector with column names for
# \code{\link[tidySEM]{table_results}}.
# @author Caspar J. van Lissa
# @family Reporting tools
# @keywords reporting
# @export
# @examples
# report_columns(c("label", "est_sig", "se", "pval", "confint", "group"))
report_columns <- function(x = c("label", "est_sig", "se", "pval", "confint", "group", "level")){
x <- list("report_columns" = x)
do.call(options, x)
}
#' Print results table formatted for publication
#'
#' Takes a model object, and formats it as a publication-ready table.
#' @param x A model object for which a method exists.
# @param standardized Logical. Return standardized parameters, or not.
# Defaults to TRUE.
# @param all Logical. Whether to return all available results columns
# (including columns generated by \code{table_results}, or whether to return a
# simplified table containing the essential columns for 'APA'-style reporting.
# Defaults to FALSE. If set to TRUE, you can manually select the desired
# columns.
#' @param columns A character vector of columns to retain from the results
#' section. If this is set to \code{NULL}, all available columns are returned.
#' Defaults to \code{c("label", "est_sig", "se", "pval", "confint", "group",
#' "level")}. These correspond to 1) the parameter label, 2) estimate column
#' with significance asterisks appended
#' (* <.05, ** < .01, *** < .001); 3) standard error, 4) p-value, 5) a
#' formatted confidence interval, 6) grouping variable (if available), 7) level
#' variable for multilevel models, if available.
#' @param digits Number of digits to round to when formatting numeric columns.
#' @param format_numeric Logical, indicating whether or not to format numeric
#' columns. Defaults to `TRUE`.
#' @param ... Logical expressions used to filter the rows of results returned.
#' @return A data.frame of formatted results.
#' @author Caspar J. van Lissa
#' @family Reporting tools
#' @keywords reporting
#' @export
#' @examples
#' library(lavaan)
#' HS.model <- ' visual =~ x1 + x2 + x3
#' textual =~ x4 + x5 + x6
#' speed =~ x7 + x8 + x9 '
#' fit <- cfa(HS.model,
#' data = HolzingerSwineford1939,
#' group = "school")
#' table_results(fit)
table_results <- function(x, columns = c("label", "est_sig", "se", "pval", "confint", "group", "level"), digits = 2, format_numeric = TRUE, ...){
UseMethod("table_results")
}
#' @method table_results mplusObject
#' @export
table_results.mplusObject <- function(x, columns = c("label", "est_sig", "se", "pval", "confint", "group", "level"), digits = 2, format_numeric = TRUE, ...){
cl <- match.call()
cl$x <- x$results
cl[[1L]] <- quote(table_results)
eval.parent(cl)
}
#' @method table_results mplus.model
#' @importFrom MplusAutomation SummaryTable
#' @export
table_results.mplus.model <- function(x, columns = c("label", "est_sig", "se", "pval", "confint", "group", "level"), digits = 2, format_numeric = TRUE, ...){
Args <- list(x = x)
cl <- match.call()
get_res <- c("unstandardized", "stdyx.standardized")[which( c("unstandardized", "stdyx.standardized") %in% names(x$parameters))]
all_res <- lapply(get_res, function(which_par){do.call(internal_table_mplusmodel, c(Args, list(parameters = which_par, digits = digits)))})
if(length(all_res) == 1){
results <- all_res[[1]]
if(is.null(results)){
message("No valid results found.")
invisible(return(NULL))
}
} else {
all_res[[2]][c("paramHeader", "param", "est_se", "Group", "betweenwithin", "label")] <- NULL
names(all_res[[2]])[-ncol(all_res[[2]])] <- paste0(names(all_res[[2]])[-ncol(all_res[[2]])], "_std")
results <- merge(all_res[[1]], all_res[[2]], by = "id", all.x = TRUE)
results["id"] <- NULL
}
results <- data.frame(mplus_to_lavaan_labels(results$paramHeader, results$param), results, stringsAsFactors = FALSE)
if(any(results$paramHeader == "New.Additional.Parameters")){
results$rhs[results$op == ":="] <- sapply(results$lhs[results$op == ":="], function(constr){
trimws(gsub("^.+?=(.+);", "\\1", x$input$model.constraint[grepl(paste0("(?<=\\s)", tolower(constr), "(?=[= ])"), tolower(x$input$model.constraint), perl = TRUE)]))
})
}
names(results) <- tolower(names(results))
if("betweenwithin" %in% names(results)) names(results)[names(results) == "betweenwithin"] <- "level"
# Drop id column
results[["id"]] <- NULL
if(!is.null(columns)){
results <- results[, na.omit(match(columns, names(results))), drop = FALSE]
} else {
first_cols <- c("lhs", "op", "rhs", "paramheader", "param", "est", "se", "est_se",
"pval", "est_sig", "confint", "est_std", "se_std", "pval_std",
"est_sig_std", "confint_std")
last_cols <- c("group", "level", "label")
order_cols <- c(names(results)[names(results) %in% first_cols],
names(results)[!names(results) %in% c(first_cols, last_cols)],
names(results)[names(results) %in% last_cols])
results <- results[, order_cols, drop = FALSE]
}
class(results) <- c("tidy_results", class(results))
results
}
internal_table_mplusmodel <- function(x, parameters, digits = 2, format_numeric = TRUE){
results <- x$parameters[[parameters]]
if(is.null(results[["se"]])){
return(NULL)
}
add_cis <- FALSE
if(!is.null(x$parameters[[paste0("ci.", parameters)]])){
if(dim(results)[1]==dim(x$parameters[[paste0("ci.", parameters)]])[1]){
add_cis <- TRUE
results <- cbind(results, x$parameters[[paste0("ci.", parameters)]][, c("low2.5", "up2.5")])
}
}
if(!is.null(x$indirect[[parameters]])){
overall <- x$indirect[[parameters]]$overall
if(!is.null(overall)){
if(!is.null(overall[["summary"]])){
paramHeader <- gsub("\\s+", "\\.", overall[["summary"]])
} else {
paramHeader <- "Sum.of.indirect"
}
param <- paste(overall$outcome, overall$pred, sep = ".")
overall$pred <- paramHeader
overall$outcome <- param
names(overall)[c(1, 2)] <- c("paramHeader", "param")
if(add_cis){
overall <- cbind(overall, x$indirect[[paste0("ci.", parameters)]]$overall[, c("low2.5", "up2.5")])
}
names(overall)[match(tolower(names(results)), tolower(names(overall)))] <- names(results)[na.omit(match(tolower(names(overall)), tolower(names(results))))]
results <- rbind(results, overall[, match(names(results), names(overall))])
}
specific <- x$indirect[[parameters]]$specific
if(!is.null(specific)){
paramHeader <- "Specific.indirect"
param <- paste(specific$pred, specific$intervening, specific$outcome, sep = ".")
specific$pred <- paramHeader
specific$intervening <- param
names(specific)[c(1, 2)] <- c("paramHeader", "param")
if(add_cis){
specific <- cbind(specific, x$indirect[[paste0("ci.", parameters)]]$specific[, c("low2.5", "up2.5")])
}
names(specific)[match(tolower(names(results)), tolower(names(specific)))] <- names(results)[na.omit(match(tolower(names(specific)), tolower(names(results))))]
results <- rbind(results, specific[, match(names(results), names(specific))])
}
}
# CHeck which columns can be numeric
value_columns <- names(results)[can_be_numeric(results)]
var_classes <- sapply(results[value_columns], class)
results[value_columns[which(var_classes == "character")]] <- lapply(results[value_columns[which(var_classes == "character")]], as.numeric)
results[value_columns[which(var_classes == "factor")]] <- lapply(results[value_columns[which(var_classes == "factor")]], as_numeric_factor)
constrained_rows <- results$pval == 999
results$label <- param_label(results)
if(all(c("est", "pval") %in% names(results))){
# Call est_sig
cl <- match.call()
cl <- cl[c(1, which(names(cl) %in% c("x", "digits", "sig")))]
cl[["x"]] <- results$est
cl[["sig"]] <- results$pval
cl[[1L]] <- quote(est_sig)
results$est_sig <- eval.parent(cl)
}
# Call conf_int
cl <- match.call()
cl <- cl[c(1, which(names(cl) %in% c("x", "digits", "se", "lb", "ub", "ci")))]
cl[["x"]] <- results
cl[[1L]] <- quote(conf_int)
results$confint <- eval.parent(cl)
if(format_numeric){
results[, value_columns] <- lapply(results[, value_columns], format_with_na, digits = digits, format = "f")
}
results[constrained_rows, which(names(results) %in% c("se", "pval", "est_se", "confint"))] <- NA
id_cols <- c("paramHeader", "param", "Group", "betweenwithin", "LatentClass")
results$id <- do.call(paste0, results[which(names(results) %in% id_cols)])
results
}
mplus_to_lavaan_labels <- function(paramHeader, param){
op <- paramHeader
op[grepl("^.+?\\.\\|$", op)] <- "=~"
op[op == "New.Additional.Parameters"] <- ":="
op[op == "Thresholds"] <- "|"
op[op %in% c("Residual.Variances", "Variances")] <- "~~"
with_statements <- grepl("^.+?\\.WITH$", op)
op[with_statements] <- "~~"
op[op %in% c("Means", "Intercepts")] <- "~1"
op[grepl("^.+?\\.ON$", op)] <- "~"
op[grepl("^.+?\\.BY$", op)] <- "=~"
rhs <- lhs <- param
rhs[op == "~1"] <- ""
lhs[op %in% c("~", "=~")] <- unlist(sapply(strsplit(paramHeader[op %in% c("~", "=~")], "\\."), `[`, 1))
lhs[with_statements] <- unlist(sapply(strsplit(paramHeader[with_statements], "\\."), `[`, 1))
cbind(lhs, op, rhs)
}
lavaan_labels <- function(x){
x$left <- x$mid <- ""
x$mid[x$op == "=~"] <- "BY"
x$mid[x$op == ":="] <- ":="
x$left[x$op == "|"] <- "Thresholds"
#x$rhs[x$op == "|"] <- paste0(".", x$rhs[x$op == "|"])
x$mid[x$op == "~~" & !(x$lhs == x$rhs)] <- "WITH"
x$left[x$op == "~1"] <- "Means"
x$mid[x$op == "~"] <- "ON"
x$left[x$op %in% c("~~", "~*~") & x$lhs == x$rhs] <- "Variances"
x$rhs[x$op %in% c("~~", "~*~") & x$lhs == x$rhs] <- ""
apply(x[c("left", "lhs", "mid", "rhs")], 1, function(i){
paste0(i[!i==""], collapse = ".")
})
}
#' Add significance asterisks to object
#'
#' Takes an object, and adds significance asterisks.
#' @param x An object for which a method exists. This will be treated as numeric
#' by the default method.
#' @param digits Integer. The number of digits to round the estimate column to.
#' @param sig Optional, a vector of p-values for the default method.
#' @return A character vector of formatted estimates.
#' @author Caspar J. van Lissa
#' @family Reporting tools
#' @seealso table_results
#' @export
#' @examples
#' est_sig(c(.222, .3333), sig = c(.054, .045))
est_sig <- function(x, digits = 2, sig = NULL){
UseMethod("est_sig")
}
#' @method est_sig default
#' @export
est_sig.default <- function(x, digits = 2, sig = NULL){
out <- format_with_na(x, digits = digits, format = "f")
out[which(sig<.05)] <- paste0(out[which(sig<.05)], "*")
out[which(sig<.01)] <- paste0(out[which(sig<.01)], "*")
out[which(sig<.001)] <- paste0(out[which(sig<.001)], "*")
out
}
#' @method est_sig mplus.params
#' @export
est_sig.mplus.params <- function(x, digits = 2, sig = NULL){
Args <- list(x = x[["est"]],
sig = x[["pval"]])
do.call(est_sig, Args)
}
#' Format confidence intervals
#'
#' Creates 'APA'-formatted confidence intervals, either from an object for which
#' a method exists, or from the arguments \code{lb} and \code{ub}. When argument
#' \code{x} is a numeric vector, it is also possible to construct a confidence
#' interval using the standard error (\code{se}) and a percentile interval
#' (\code{ci}).
#' @param x Optional. An object for which a method exists.
#' @param digits Integer. The number of digits to round the confidence
#' boundaries to.
#' @param se Optional, numeric. Standard error of the parameters.
#' @param lb Optional, numeric. Lower boundary of confidence intervals.
#' @param ub Optional, numeric. Upper boundary of confidence intervals.
#' @param ci Optional, numeric. What percentage CI to use (only used when
#' computing CI from a numeric vector \code{x}, and the standard error
#' \code{se}, based on a normal distribution).
#' @return A character vector of formatted confidence intervals.
#' @author Caspar J. van Lissa
#' @family Reporting tools
#' @seealso table_results est_sig
#' @export
#' @examples
#' conf_int(x = c(1.325, 2.432), se = c(.05336, .00325))
conf_int <- function(x, digits = 2, se = NULL, lb = NULL, ub = NULL, ci = 95){
UseMethod("conf_int")
}
#' @method conf_int default
#' @export
#' @importFrom stats qnorm
conf_int.default <- function(x, digits = 2, se = NULL, lb = NULL, ub = NULL, ci = 95){
if(!is.null(se) & !is.null(lb) & !is.null(ub)) {
message("Both se and lb/ub provided. Used lb/ub to construct confidence interval.", call. = FALSE)
se <- NULL
}
if(!is.null(lb) & !is.null(ub)){
formatlb <- format_with_na(lb, digits = digits, format = "f")
formatub <- format_with_na(ub, digits = digits, format = "f")
} else {
if(!(ci>0 & ci < 100)) stop("Argument 'ci' must have a value between 0-100.", call. = FALSE)
bound <- qnorm((1-(ci/100))/2)
formatlb <- format_with_na(x+(bound*se), digits = digits, format = "f")
formatub <- format_with_na(x-(bound*se), digits = digits, format = "f")
}
out <- paste0("[", formatlb, ", ", formatub, "]")
out[is.na(formatlb) & is.na(formatub)] <- NA
return(out)
}
#' @method conf_int mplus.params
#' @export
conf_int.mplus.params <- function(x, digits = 2, se = NULL, lb = NULL, ub = NULL, ci = 95){
if("low2.5" %in% names(x) | "lower_2.5ci" %in% names(x)){
if("low2.5" %in% names(x)){
message("Used bootstrapped confidence intervals.")
confint <- paste0("[", format_with_na(x$low2.5, digits = digits, format = "f"), ", ", format_with_na(x$up2.5, digits = digits, format = "f"), "]")
} else {
confint <- paste0("[", format_with_na(x$lower_2.5ci, digits = digits, format = "f"), ", ", format_with_na(x$upper_2.5ci, digits = digits, format = "f"), "]")
}
} else {
message("Calculated confidence intervals from est and se.")
confint <- paste0("[", format_with_na(x$est-(1.96*x$se), digits = digits, format = "f"), ", ", format_with_na(x$est+(1.96*x$se), digits = digits, format = "f"), "]")
}
gsub("^ \\[", "\\[ ", gsub("([^-]\\d\\.\\d{2})", " \\1", confint))
}
# Add parameter labels to Mplus output
#
# Sometimes a single parameter label is more convenient than the two (or more)
# columns returned by \code{readModels}. This function constructs parameter
# labels by concatenating the paramHeader and param columns, or other relevant
# label columns
# @param mplusresults An mplusModel object, as returned by \code{readModels}.
# @return A character vector of parameter labels.
# @author Caspar J. van Lissa
# @family Mplus functions
# @seealso \code{\link[MplusAutomation]{readModels}}.
# @export
# @examples
# data <- data.frame(paramHeader = c("F.BY", "F.BY"), param = c("A", "B"))
# param_label(data)
param_label <- function(mplusresults){
label_columns <- c("paramheader", "param", "pred", "intervening", "summary", "outcome", "group", "betweenwithin")
label_columns <- names(mplusresults)[which(tolower(names(mplusresults)) %in% label_columns)]
return(apply(mplusresults[label_columns], 1, paste0, collapse = "."))
if(!is.null(mplusresults[["paramHeader"]])&!is.null(mplusresults[["param"]])){
return(paste(mplusresults$paramHeader, mplusresults$param, sep = "."))
}
if(!is.null(mplusresults[["pred"]])&!is.null(mplusresults[["intervening"]])&!is.null(mplusresults[["outcome"]])){
return(paste("IND", mplusresults$pred, mplusresults$intervening, mplusresults$outcome, sep = "."))
}
if(!is.null(mplusresults[["pred"]])&!is.null(mplusresults[["summary"]])&!is.null(mplusresults[["outcome"]])){
return(paste(gsub("\\s", "\\.", mplusresults$summary), mplusresults$outcome, mplusresults$pred, sep = "."))
}
}
# Row-binds tables for publication
#
# Converts tables (data.frames, matrices) to character, and row-binds them,
# inserting a label into the first column for each sub-table.
# @param table_list A list of tables.
# @return A table.
# @author Caspar J. van Lissa
# @family Mplus functions
# @export
# @examples
# table_list <- list(
# table_f = data.frame(paramHeader = c("F.BY", "F.BY"), param = c("A", "B")),
# table_g = data.frame(paramHeader = c("G.BY", "G.BY"), param = c("A", "B")))
# table_list <- list(
# data.frame(paramHeader = c("F.BY", "F.BY"), param = c("A", "B")),
# data.frame(paramHeader = c("G.BY", "G.BY"), param = c("A", "B")))
# rbind_tables(table_list)
rbind_tables <- function(table_list){
if(length(unique(sapply(table_list, ncol))) > 1) stop("Not all tables have the same number of columns.")
if(is.null(names(table_list))) names(table_list) <- 1:length(table_list)
do.call(rbind,
lapply(names(table_list), function(x){
rbind(
c(x, rep("", (ncol(table_list[[x]])-1))), sapply(table_list[[x]], as.character))
})
)
}
#' Extract correlation tables
#'
#' Extracts a publication-ready covariance or correlation matrix from an object
#' for which a method exists.
#' @param x An object for which a method exists.
#' @param value_column Character. Name of the column to use to propagate the
#' matrix. Defaults to "est_sig_std", the standardized estimate with
#' significance asterisks.
#' @param digits Number of digits to round to when formatting values.
#' @param ... Additional arguments passed to and from methods.
#' @return A Matrix or a list of matrices (in case there are between/within
#' correlation matrices).
#' @author Caspar J. van Lissa
#' @export
#' @examples
#' library(lavaan)
#' HS.model <- ' visual =~ x1 + x2 + x3
#' textual =~ x4 + x5 + x6
#' speed =~ x7 + x8 + x9 '
#' fit <- cfa(HS.model,
#' data = HolzingerSwineford1939,
#' group = "school")
#' table_cors(fit)
table_cors <- function(x, value_column = "est_sig_std", digits = 2, ...){
UseMethod("table_cors", x)
}
#' @method table_cors default
#' @export
table_cors.default <- function(x, value_column = "est_sig_std", digits = 2, ...){
correlations <- table_results(x, columns = NULL, digits = digits)
grouping_cols <- c("group", "level")[c("group", "level") %in% names(correlations)]
if(length(grouping_cols) > 0){
if(length(grouping_cols) > 1){
correlations$split_id <- do.call(paste0, c(list(sep = "_"), correlations[, grouping_cols]))
} else {
correlations$split_id <- correlations[[grouping_cols]]
}
}
.table_cor_internal(correlations = correlations, value_column = value_column)
}
.table_cor_internal <- function(correlations, value_column){
if("split_id" %in% names(correlations)){
outlist <- lapply(unique(correlations$split_id), function(i){
.table_cor_internal(correlations = correlations[correlations$split_id == i, -which(names(correlations) == "split_id")],
value_column = value_column)
})
names(outlist) <- unique(correlations$split_id)
return(outlist)
}
# End recursion
cors <- correlations[is_cor(correlations), c("lhs", "rhs", value_column)]
cor_order <- unique(c(rbind(cors$lhs, cors$rhs)))
names(cors)[3] <- "value"
cors <- rbind(cors, data.frame(lhs = cors$rhs, rhs = cors$lhs, value = cors$value))
vars <- t(sapply(unique(cors$lhs), function(x){unlist(correlations[correlations$lhs == x & correlations$rhs == x & correlations$op == "~~", c("lhs", "rhs", value_column)])}))
colnames(vars)[3] <- "value"
cors <- rbind(cors, vars)
should_have <- expand.grid(cor_order, cor_order, stringsAsFactors = FALSE)
for(i in 1:nrow(should_have)){
if(!any(apply(cors[, 1:2], 1, function(x){ all(x == should_have[i, ])}))){
cors[(nrow(cors)+1), ] <- c(unlist(should_have[i, , drop = TRUE]), NA)
}
}
cors <- cors[order(cors$lhs, cors$rhs),]
out <- matrix(cors$value, ncol = length(unique(cors$lhs)))
rownames(out) <- colnames(out) <- unique(cors$lhs)
out[is.na(out)] <- ""
out
}
#' @importFrom utils getFromNamespace
#' @importFrom lavaan parametertable lavInspect standardizedsolution
lav_getParameterLabels <-
getFromNamespace("getParameterLabels", "lavaan")
#' @importFrom lavaan parameterEstimates lavInspect standardizedsolution partable
#' @method table_results lavaan
#' @export
table_results.lavaan <- function(x, columns = c("label", "est_sig", "se", "pval", "confint", "group", "level"), digits = 2, format_numeric = TRUE, ...){
# Rename dictionary for consistency with mplus
user_specified <- partable(x)
remthese <- which(
(user_specified$op == "==" & user_specified$user != 1L) |
(user_specified$op == "==" & user_specified$user == 1L) |
(user_specified$op %in% c("<", ">")))
if(length(remthese > 0)) user_specified <- user_specified[-remthese, , drop = FALSE]
user_specified <- (user_specified$free != 0 | !is.na(user_specified$ustart))
rename_dict <- c("pvalue" = "pval")
pars_unst <- parameterEstimates(x)
if("label" %in% names(pars_unst)){
names(pars_unst)[names(pars_unst) == "label"] <- "lavaan_label"
}
# Rename columns for consistency with mplus
names(pars_unst)[match(names(rename_dict), names(pars_unst))] <- rename_dict[names(rename_dict) %in% names(pars_unst)]
pars_unst$label <- lavaan_labels(pars_unst)
num_groups <- lavInspect(x, what = "ngroups")
if(num_groups > 1){
group_labels <- lavInspect(x, what = "group.label")
if(!all(group_labels %in% unique(pars_unst$group))){
if(is.numeric(pars_unst$group)){
pars_unst$group[pars_unst$group > 0] <- group_labels[pars_unst$group]
pars_unst$group[pars_unst$group == 0] <- NA
}
}
pars_unst$label <- paste2(pars_unst$label, pars_unst$group, sep = ".")
}
if("level" %in% names(pars_unst)){
pars_unst$label <- paste2(pars_unst$label, pars_unst$level, sep = ".")
}
# Unst
# Call conf_int
cl <- match.call()
cl <- cl[c(1, which(names(cl) %in% c("x", "digits", "se", "lb", "ub", "ci")))]
cl[["x"]] <- pars_unst$est
cl[["lb"]] <- pars_unst$ci.lower
cl[["ub"]] <- pars_unst$ci.upper
cl[[1L]] <- quote(conf_int)
pars_unst$confint <- eval(cl)
# Call est_sig
cl <- match.call()
cl <- cl[c(1, which(names(cl) %in% c("x", "digits", "sig")))]
cl[["x"]] <- pars_unst$est
cl[["sig"]] <- pars_unst$pval
cl[[1L]] <- quote(est_sig)
pars_unst$est_sig <- eval(cl)
pars_unst[c("z", "ci.lower", "ci.upper")] <- NULL
# Std
pars_std <- standardizedsolution(x)
names(pars_std)[match(names(rename_dict), names(pars_std))] <- rename_dict[names(rename_dict) %in% names(pars_std)]
# Call conf_int
cl <- match.call()
cl <- cl[c(1, which(names(cl) %in% c("x", "digits", "se", "lb", "ub", "ci")))]
cl[["x"]] <- pars_std$est
cl[["lb"]] <- pars_std$ci.lower
cl[["ub"]] <- pars_std$ci.upper
cl[[1L]] <- quote(conf_int)
pars_std$confint <- eval(cl)
# Call est_sig
cl <- match.call()
cl <- cl[c(1, which(names(cl) %in% c("x", "digits", "sig")))]
cl[["x"]] <- pars_std$est
cl[["sig"]] <- pars_std$pval
cl[[1L]] <- quote(est_sig)
pars_std$est_sig <- eval(cl)
# Remove redundant columns
pars_std[c("lhs", "op", "rhs", "group", "z", "ci.lower", "ci.upper")] <- NULL
names(pars_std)[na.omit(match(c("se", "pval", "est_sig", "confint"), names(pars_std)))] <- paste0(names(pars_std)[na.omit(match(c("se", "pval", "est_sig", "confint"), names(pars_std)))], "_std")
if("est.std" %in% names(pars_std)) names(pars_std)[which(names(pars_std) == "est.std")] <- "est_std"
if("label" %in% names(pars_std)) names(pars_std)[which(names(pars_std) == "label")] <- "lavaan_label"
results <- cbind(pars_unst, pars_std)
results <- two_to_one(results)
# Apply digits
fixed_parameters <- is.na(results$z)
value_columns <- names(results)[can_be_numeric(results)]
if(format_numeric){
results[, value_columns] <- lapply(results[, value_columns],
format_with_na, digits = digits, format = "f")
}
results[fixed_parameters, c("z", "se", "pval", "se_std", "pval_std")[which(c("z", "se", "pval", "se_std", "pval_std") %in% names(results))]] <- ""
if(!is.null(columns)){
results <- results[, na.omit(match(columns, names(results))), drop = FALSE]
} else {
first_cols <- c("lhs", "op", "rhs", "est", "se", "pval", "est_sig", "confint",
"est_std", "se_std", "pval_std", "est_sig_std", "confint_std")
last_cols <- c("block", "group", "level", "lavaan_label", "mplus_label", "label")
order_cols <- c(names(results)[names(results) %in% first_cols],
names(results)[!names(results) %in% c(first_cols, last_cols)],
names(results)[names(results) %in% last_cols])
results <- results[, order_cols, drop = FALSE]
}
class(results) <- c("tidy_results", class(results))
if(length(user_specified) == nrow(results)) attr(results, "user_specified") <- user_specified
results
}
#' @importFrom lavaan parameterEstimates standardizedsolution
#' @importFrom blavaan blavInspect
#' @method table_results blavaan
#' @export
table_results.blavaan <- function(x, columns = c("label", "est_sig", "se", "pval", "confint", "group", "level"), digits = 2, format_numeric = TRUE, ...){
# Rename dictionary for consistency with mplus
user_specified <- blavInspect(x, "list")
remthese <- which(
(user_specified$op == "==" & user_specified$user != 1L) |
(user_specified$op == "==" & user_specified$user == 1L) |
(user_specified$op %in% c("<", ">")))
if(length(remthese > 0)) user_specified <- user_specified[-remthese, , drop = FALSE]
user_specified <- (user_specified$free != 0 | !is.na(user_specified$ustart))
pars_unst <- parameterEstimates(x)
if("label" %in% names(pars_unst)){
names(pars_unst)[names(pars_unst) == "label"] <- "lavaan_label"
}
# Rename columns for consistency with mplus
pars_unst$label <- lavaan_labels(pars_unst)
num_groups <- blavInspect(x, what = "ngroups")
if(num_groups > 1){
group_labels <- blavInspect(x, what = "group.label")
if(!all(group_labels %in% unique(pars_unst$group))){
if(is.numeric(pars_unst$group)){
pars_unst$group[pars_unst$group > 0] <- group_labels[pars_unst$group]
pars_unst$group[pars_unst$group == 0] <- NA
}
}
pars_unst$label <- paste2(pars_unst$label, pars_unst$group, sep = ".")
}
if("level" %in% names(pars_unst)){
pars_unst$label <- paste2(pars_unst$label, pars_unst$level, sep = ".")
}
pars_unst$est_sig <- pars_unst$est
pars_unst[c("z", "ci.lower", "ci.upper")] <- NULL
# Std
pars_std <- standardizedsolution(x)
pars_std$est_sig <- pars_std$est
# Remove redundant columns
pars_std[c("lhs", "op", "rhs", "group", "z", "ci.lower", "ci.upper")] <- NULL
names(pars_std)[na.omit(match(c("se", "pval", "est_sig", "confint"), names(pars_std)))] <- paste0(names(pars_std)[na.omit(match(c("se", "pval", "est_sig", "confint"), names(pars_std)))], "_std")
if("est.std" %in% names(pars_std)) names(pars_std)[which(names(pars_std) == "est.std")] <- "est_std"
if("label" %in% names(pars_std)) names(pars_std)[which(names(pars_std) == "label")] <- "lavaan_label"
results <- cbind(pars_unst, pars_std)
results <- two_to_one(results)
# Apply digits
fixed_parameters <- is.na(results$z)
value_columns <- names(results)[can_be_numeric(results)]
if(format_numeric){
results[, value_columns] <- lapply(results[, value_columns],
format_with_na, digits = digits, format = "f")
}
results[fixed_parameters, c("z", "se", "pval", "se_std", "pval_std")[which(c("z", "se", "pval", "se_std", "pval_std") %in% names(results))]] <- ""
if(!is.null(columns)){
results <- results[, na.omit(match(columns, names(results))), drop = FALSE]
} else {
first_cols <- c("lhs", "op", "rhs", "est", "se", "pval", "est_sig", "confint",
"est_std", "se_std", "pval_std", "est_sig_std", "confint_std")
last_cols <- c("block", "group", "level", "lavaan_label", "mplus_label", "label")
order_cols <- c(names(results)[names(results) %in% first_cols],
names(results)[!names(results) %in% c(first_cols, last_cols)],
names(results)[names(results) %in% last_cols])
results <- results[, order_cols, drop = FALSE]
}
class(results) <- c("tidy_results", class(results))
if(length(user_specified) == nrow(results)) attr(results, "user_specified") <- user_specified
results
}
#' @method table_results character
#' @export
table_results.character <- function(x, columns = c("label", "est_sig", "se", "pval", "confint", "group", "level"), digits = 2, format_numeric = TRUE, ...){
cl <- match.call()
cl <- cl[-which(names(cl) %in% c("x", "columns", "digits"))]
cl[[1L]] <- str2lang("lavaan::lavaanify")
cl[["model"]] <- x
results <- eval.parent(cl)
class(results) <- c("tidy_results", class(results))
results
}
# table_results.character("y ~ x", ngroups = 2)
can_be_numeric <- function(x){
out <- sapply(x, function(col){ tryCatch(expr = {as.numeric(col); return(TRUE)}, warning= function(w){ return(FALSE) }) })
out & !sapply(x, inherits, what = "logical")
}
format_with_na <- function(x, ...){
cl <- match.call()
missings <- is.na(x)
out <- rep(NA, length(x))
cl$x <- na.omit(x)
cl[[1L]] <- quote(formatC)
out[!missings] <- eval.parent(cl)
out
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.