Nothing
#' @title Print Method of a 'semlbci' Object
#'
#' @description Prints the results of a `semlbci` object, the output
#' of [semlbci()].
#'
#' @details Prints the results of [semlbci()] as a table.
#'
#' @return
#' `x` is returned invisibly. Called for its side effect.
#'
#' @param x The output of [semlbci()].
#'
#' @param digits The number of digits after the decimal point. To be
#' passed to [formatC()]. Default is 3.
#'
#' @param time If `TRUE`, print the time spent on each bound. Default
#' is `FALSE`.
#'
#' @param annotation If `TRUE`, print table notes. Default is `TRUE`.
#'
#' @param verbose If `TRUE`, additional diagnostic information will
#' always be printed. This argument overrides `verbose_if_needed`.
#' Default is `FALSE`.
#'
#' @param verbose_if_needed If `TRUE`, additional diagnostic
#' information will be printed only if necessary. If `FALSE`,
#' additional diagnostic information will always be printed. Default
#' is `TRUE`.
#'
#' @param drop_no_lbci If `TRUE`, parameters without LBCIs will be
#' removed. Default is `TRUE`.
#'
#' @param output The type of printout.
#' If `"table"`, the default, the
#' results will be printed in a table.
#' If `"text"` or `"lavaan"`, then the
#' results will be printed in the
#' `lavaan` style, as in the [summary()]
#' method for the output of `lavaan`.
#'
#' @param sem_out If `output` is
#' `"text"` or `"lavaan"`, the original
#' output of `lavaan` used in calling
#' [semlbci()] needs to be supplied
#' to this argument.
#'
#' @param lbci_only Used only if `output`
#' is `"text"` or `"lavaan"`. If `TRUE`,
#' only the likelihood-based confidence
#' intervals (LBCIs) will be printed.
#' If `FALSE`, and LBCIs will be
#' printed alongside the confidence
#' intervals by `lavaan`. Its default
#' value depend on the argument
#' `drop_no_lbci`. If `drop_no_lbci`
#' is `TRUE`, then `lbci_only` is
#' `TRUE` by default. If `drop_no_lbci`
#' is `FALSE`, then `lbci_only` is
#' `FALSE` by default.
#'
#' @param ratio_digits The number of
#' digits after the decimal points
#' for the ratios of distance from
#' the confidence limits
#' to the point estimates. Default is
#' 1.
#'
#' @param se Logical. To be passed to
#' [lavaan::parameterEstimates()].
#' Whether standard error (S.E.) will be
#' printed. Only applicable if `output`
#' is `"text"` or `"lavaan"`.
#'
#' @param zstat Logical. To be passed to
#' [lavaan::parameterEstimates()].
#' Whether z-values will be printed.
#' Only applicable if `output` is
#' `"text"` or `"lavaan"`.
#'
#' @param pvalue Logical. To be passed
#' to [lavaan::parameterEstimates()].
#' Whether p-values will be printed.
#' Only applicable if `output` is
#' `"text"` or `"lavaan"`.
#'
#' @param boot.ci.type Logical. To be
#' passed to
#' [lavaan::parameterEstimates()]. The
#' type of bootstrap confidence
#' intervals to be printed if
#' bootstrapping confidence intervals
#' available. Possible values are
#' `"norm"`, `"basic"`, `"perc"`, or
#' `"bca.simple"`. The default value is
#' `"perc"`. Refer to the help of
#' [lavaan::parameterEstimates()] for
#' further information. Only applicable
#' if `output` is `"text"` or
#' `"lavaan"`.
#'
#' @param ... Other arguments. They will be ignored.
#'
#' @author Shu Fai Cheung <https://orcid.org/0000-0002-9871-9448>
#'
#' @seealso [semlbci()]
#'
#' @examples
#'
#' library(lavaan)
#' mod <-
#' "
#' m ~ a*x
#' y ~ b*m
#' ab := a * b
#' "
#' fit_med <- sem(mod, simple_med, fixed.x = FALSE)
#' p_table <- parameterTable(fit_med)
#' p_table
#' lbci_med <- semlbci(fit_med,
#' pars = c("ab :="))
#' lbci_med
#'
#' print(lbci_med, verbose_if_needed = FALSE)
#'
#' print(lbci_med, verbose = TRUE)
#'
#' print(lbci_med, time = TRUE)
#'
#' print(lbci_med, annotation = FALSE)
#'
#' print(lbci_med, digits = 4)
#'
#' # Text output
#'
#' print(lbci_med, output = "lavaan", sem_out = fit_med)
#'
#' print(lbci_med, output = "lavaan", sem_out = fit_med, lbci_only = FALSE)
#'
#' print(lbci_med, output = "lavaan", sem_out = fit_med, lbci_only = FALSE,
#' se = FALSE, zstat = FALSE, pvalue = FALSE)
#'
#' @export
print.semlbci <- function(x,
digits = 3,
annotation = TRUE,
time = FALSE,
verbose = FALSE,
verbose_if_needed = TRUE,
drop_no_lbci = TRUE,
output = c("table", "text", "lavaan"),
sem_out = NULL,
lbci_only = drop_no_lbci,
ratio_digits = 1,
se = TRUE,
zstat = TRUE,
pvalue = TRUE,
boot.ci.type = "perc",
...) {
output <- match.arg(output)
if (isTRUE(output == "lavaan")) output <- "text"
if (verbose) verbose_if_needed <- FALSE
if (isTRUE(output == "text")) {
if (is.null(sem_out)) {
stop("Argument 'sem_out' must be supplied ",
"if output type is 'text' or 'lavaan'.")
}
if (!compare_semlbci_sem_out(x,
sem_out = sem_out)) {
stop("The value of 'sem_out' does not appear ",
"to be the fit object used in the call ",
"to 'semlbci()'.")
}
print_semlbci_text(x = x,
nd = digits,
sem_out = sem_out,
lbci_only = lbci_only,
drop_no_lbci = drop_no_lbci,
annotation = annotation,
verbose = verbose,
verbose_if_needed = verbose_if_needed,
ratio_digits = ratio_digits,
se = se,
zstat = zstat,
pvalue = pvalue,
boot.ci.type = boot.ci.type,
...)
return(invisible(x))
}
out <- x
if (max(out$group) == 1) {
out$group <- NULL
}
if (all(out$label == "")) {
out$label <- NULL
}
class(out) <- "data.frame"
out$lbci_lb <- formatC(out$lbci_lb, digits, format = "f", mode = "double")
if ("est.std" %in% colnames(x)) {
standardized <- TRUE
out$est.std <- formatC(out$est.std, digits, format = "f", mode = "double")
} else {
standardized <- FALSE
out$est <- formatC(out$est, digits, format = "f", mode = "double")
}
out$lbci_ub <- formatC(out$lbci_ub, digits, format = "f", mode = "double")
out$ci_org_lb <- formatC(out$ci_org_lb, digits, format = "f", mode = "double")
out$ci_org_ub <- formatC(out$ci_org_ub, digits, format = "f", mode = "double")
out$ratio_lb <- formatC(out$ratio_lb, digits, format = "f", mode = "double")
out$ratio_ub <- formatC(out$ratio_ub, digits, format = "f", mode = "double")
out$cl_lb <- formatC(out$cl_lb, digits, format = "f", mode = "double")
out$cl_ub <- formatC(out$cl_ub, digits, format = "f", mode = "double")
call_org <- attr(out, "call")
if (drop_no_lbci) {
out <- out[!is.na(out$status_lb), ]
}
if (!time) {
out$time_lb <- NULL
out$time_ub <- NULL
}
if (verbose_if_needed) {
verbose_chk <- verbose_needed(out)
ratio_note <- verbose_chk$ratio_note
post_check_note <- verbose_chk$post_check_note
status_note <- verbose_chk$status_note
# if (is.null(call_org$ci_limit_ratio_tol)) {
# ci_limit_ratio_tol <- formals(ci_bound_wn_i)$ci_limit_ratio_tol
# } else {
# ci_limit_ratio_tol <- call_org$ci_limit_ratio_tol
# }
# ratio_x <- c(out$ratio_lb, out$ratio_ub)
# ratio_note <- any(ratio_x > ci_limit_ratio_tol, na.rm = TRUE) |
# any(ratio_x < 1 / ci_limit_ratio_tol, na.rm = TRUE)
if (!ratio_note) {
out$ratio_lb <- NULL
out$ratio_ub <- NULL
}
# post_check_note <- !all(out$post_check_lb,
# out$post_check_ub,
# na.rm = TRUE)
if (!post_check_note) {
out$post_check_lb <- NULL
out$post_check_ub <- NULL
}
# status_note <- !all(out$status_lb == 0,
# out$status_ub == 0,
# na.rm = TRUE)
if (!status_note) {
out$status_lb <- NULL
out$status_ub <- NULL
}
} else {
ratio_note <- TRUE
post_check_note <- TRUE
status_note <- TRUE
}
out$method <- NULL
out_names <- colnames(out)
out_names <- gsub("ci_org_lb", "lb", out_names, fixed = TRUE)
out_names <- gsub("ci_org_ub", "ub", out_names, fixed = TRUE)
out_names <- gsub("status_lb", "ok_l", out_names, fixed = TRUE)
out_names <- gsub("status_ub", "ok_u", out_names, fixed = TRUE)
out_names <- gsub("ratio_lb", "ratio_l", out_names, fixed = TRUE)
out_names <- gsub("ratio_ub", "ratio_u", out_names, fixed = TRUE)
out_names <- gsub("post_check_lb", "check_l", out_names, fixed = TRUE)
out_names <- gsub("post_check_ub", "check_u", out_names, fixed = TRUE)
out_names <- gsub("time_lb", "sec_l", out_names, fixed = TRUE)
out_names <- gsub("time_ub", "sec_u", out_names, fixed = TRUE)
colnames(out) <- out_names
cat("\nResults:\n")
print(out)
if (annotation) {
msg <- NULL
msg <- c(msg,
"* lbci_lb, lbci_ub: The lower and upper likelihood-based bounds.")
if (standardized) {
msg <- c(msg,
paste0("* est.std: ",
"The point estimates from the original lavaan",
" standardized solution."))
} else {
msg <- c(msg,
paste0("* est: ",
"The point estimates from the original lavaan",
" output."))
}
if (status_note) {
msg <- c(msg,
paste0("* ok_l, ok_u: Whether the search encountered any problem. ",
"If no problem encountered, it is equal to 0. Any value ",
"other than 0 indicates something was wrong in the search. ",
"Try running 'semlbci()' again, setting 'semlbci_out' to this output, ",
"and set 'try_k_more_times' to a positive number greater than ",
"2 (the default), e.g., 3 to 5."))
}
if (standardized) {
msg <- c(msg,
paste0("* lb, ub: ",
"The original lower and upper bounds,",
" extracted from the original lavaan standardized",
" solution output.",
" Usually the delta method CIs for the",
" standardized parameters and user-defined parameters."))
} else {
msg <- c(msg,
paste0("* lb, ub: ",
"The original lower and upper bounds,",
" extracted from the original lavaan output.",
" Usually Wald CIs for free parameters and",
" delta method CIs for user-defined parameters"))
}
msg <- c(msg,
paste0("* cl_lb, cl_ub: ",
"One minus the p-values of chi-square difference tests",
" at the bounds.",
" Should be close to the requested level of confidence,",
" e.g., .95 for 95% confidence intervals."))
if (ratio_note) {
msg <- c(msg,
paste0("* ratio_l, ratio_u: ",
"Ratio of a to b, ",
"a = Distance from the point estimate to the likelihood-based",
" bound, b = Distance from the point estimate to the original",
" bound. A bound should be interpreted with caution if",
" the ratio is too large or too small, indicating a large",
" difference between the original interval and the",
" likelihood-based interval."))
}
if (post_check_note) {
msg <- c(msg,
paste0("* check_l, check_u: ", "Whether the final solution of ",
"a bound passed the post optimization check of lavaan ",
"by lavaan::lavInspect(fit, 'post.check'), where ",
"fit is the final solution."))
}
if ("sec_l" %in% colnames(out)) {
msg <- c(msg,
"* sec_l, sec_u: The time (in seconds) used to search a bound.")
}
if ("robust" %in% colnames(out)) {
msg <- c(msg,
paste0("* robust: ",
"The robust method used in the likelihood ratio ",
"test of lavaan in searching the robust ",
"likelihood-based bounds."))
}
if ("method" %in% colnames(out)) {
msg <- c(msg,
"* method: The method used to search the bounds.")
}
cat("\nAnnotation:\n")
cat(strwrap(msg, exdent = 4), sep = "\n")
cat("\nCall:\n")
print(call_org)
}
invisible(x)
}
#' @noRd
# A helper for printing in the 'lavaan' way.
print_semlbci_text <- function(x,
sem_out = sem_out,
nd = 3,
lbci_only = FALSE,
drop_no_lbci = FALSE,
annotation = TRUE,
verbose = FALSE,
verbose_if_needed = TRUE,
ratio_digits = 1,
se = TRUE,
zstat = TRUE,
pvalue = TRUE,
boot.ci.type = "perc",
...) {
# Adapted from lavaan::print.lavaan.parameterEstimates()
num_format <- paste("%", max(8L, nd + 5L), ".", nd, "f", sep = "")
int_format <- paste("%", max(8L, nd + 5L), "d", sep = "")
char_format <- paste("%", max(8L, nd + 5L), "s", sep = "")
x_call <- attr(x, "call")
i_no_lbci <- is.na(x$status_lb) & is.na(x$status_ub)
verbose_chk <- verbose_needed(x)
ciperc <- x_call$ciperc
if (is.null(ciperc)) {
ciperc <- formals(semlbci)$ciperc
}
x_df <- as.data.frame(x)
x_df$block <- x_df$group
x_df$ratio_check_lb <- verbose_chk$ratio_check_lb
x_df$ratio_check_ub <- verbose_chk$ratio_check_ub
if ("est.std" %in% colnames(x)) {
std <- TRUE
} else {
std <- FALSE
}
est0 <- lavaan::parameterEstimates(sem_out,
standardized = FALSE,
level = ciperc,
output = "text",
header = TRUE,
se = se,
zstat = zstat,
pvalue = pvalue,
boot.ci.type = boot.ci.type)
est1 <- est0
est1$id <- seq_len(nrow(est1))
if (std) {
# If CIs for standardized solution,
# always print standardized estimates.
std1 <- lavaan::standardizedSolution(sem_out,
type = "std.all",
ci = TRUE,
level = ciperc)
i0 <- colnames(std1) %in% c("lhs", "op", "rhs",
"group", "label",
"est.std",
"se", "z", "pvalue",
"ci.lower", "ci.upper")
est1$est <- NULL
est1$se <- NULL
est1$z <- NULL
est1$pvalue <- NULL
est1$ci.lower <- NULL
est1$ci.upper <- NULL
est1 <- merge(est1,
std1[, i0],
all.x = TRUE)
tmp <- colnames(est1)
tmp <- gsub("est.std", "est", tmp, fixed = TRUE)
colnames(est1) <- tmp
}
i0 <- colnames(x_df) %in% c("lhs", "op", "rhs",
"group", "label",
"lbci_lb", "lbci_ub",
"status_lb", "status_ub",
"ratio_lb", "ratio_ub",
"post_check_lb", "post_check_ub",
"cl_lb", "cl_ub",
"ratio_check_lb", "ratio_check_ub")
est1 <- merge(est1,
x_df[, i0],
all.x = TRUE)
est1 <- est1[order(est1$id), ]
est1$id <- NULL
est1 <- merge_attributes(est1,
est0)
class(est1) <- c("lavaan.parameterEstimates", class(est1))
i_drop <- is.na(est1$status_lb) & is.na(est1$status_ub)
est1$lbci_lb <- sprintf(num_format,
as.numeric(est1$lbci_lb))
est1$lbci_lb[i_drop] <- "--"
est1$lbci_ub <- sprintf(num_format,
as.numeric(est1$lbci_ub))
est1$lbci_ub[i_drop] <- "--"
if (drop_no_lbci) {
est1 <- est1[!i_drop, ]
}
if (verbose_if_needed) {
ratio_note <- verbose_chk$ratio_note
post_check_note <- verbose_chk$post_check_note
status_note <- verbose_chk$status_note
if (!ratio_note) {
est1$ratio_lb <- NULL
est1$ratio_ub <- NULL
est1$ratio_check_lb <- NULL
est1$ratio_check_ub <- NULL
}
if (!post_check_note) {
est1$post_check_lb <- NULL
est1$post_check_ub <- NULL
}
if (!status_note) {
est1$status_lb <- NULL
est1$status_ub <- NULL
}
} else {
ratio_note <- TRUE
post_check_note <- TRUE
status_note <- TRUE
}
est1$cl_lb <- NULL
est1$cl_ub <- NULL
if (lbci_only) {
est1$ci.lower <- NULL
est1$ci.upper <- NULL
}
ngroups <- lavaan::lavTech(sem_out, "ngroups")
if (ngroups == 1) {
est1$group <- NULL
}
est2 <- est1
if (status_note) {
est2$status_lb <- format_status(est2$status_lb)
est2$status_ub <- format_status(est2$status_ub)
est2$Status <- paste0(est2$status_lb,
";",
est2$status_ub)
est2$Status <- sprintf(char_format, est2$Status)
est2$Status[which(est2$lbci_lb == "--")] <- "--"
est2$status_lb <- NULL
est2$status_ub <- NULL
}
if (ratio_note) {
est2$ratio_lb <- format_ratio(est2$ratio_lb,
digits = ratio_digits,
flag = est2$ratio_check_lb,
where = "none")
est2$ratio_ub <- format_ratio(est2$ratio_ub,
digits = ratio_digits,
flag = est2$ratio_check_ub,
where = "none")
est2$Ratio <- paste0(est2$ratio_lb,
";",
est2$ratio_ub)
est2$Ratio <- sprintf(char_format, est2$Ratio)
est2$Ratio[which(est2$lbci_lb == "--")] <- "--"
est2$ratio_lb <- NULL
est2$ratio_ub <- NULL
est2$ratio_check_lb <- NULL
est2$ratio_check_ub <- NULL
}
if (post_check_note) {
est2$post_check_lb <- format_post_check(est2$post_check_lb)
est2$post_check_ub <- format_post_check(est2$post_check_ub)
est2$Check <- paste0(est2$post_check_lb,
";",
est2$post_check_ub)
est2$Check <- sprintf(char_format, est2$Check)
est2$Check[which(est2$lbci_lb == "--")] <- "--"
est2$post_check_lb <- NULL
est2$post_check_ub <- NULL
}
tmp <- colnames(est2)
tmp <- gsub("lbci_lb", "lb.lower", tmp, fixed = TRUE)
tmp <- gsub("lbci_ub", "lb.upper", tmp, fixed = TRUE)
colnames(est2) <- tmp
out <- utils::capture.output(print(est2, nd = nd))
if (annotation) {
# i0 <- grepl(" Standard errors ", out, fixed = TRUE)
# tmp <- out
# tmp[seq_len(which(i0))] <- "%%"
# i1 <- match("", tmp)
tmp0 <- "- lb.lower, lb.upper: "
tmp <- paste0(tmp0,
"The lower and upper likelihood-based ",
"confidence bounds.")
tmp <- strwrap(tmp,
indent = 0,
exdent = nchar(tmp0))
msg <- tmp
if (status_note) {
tmp0 <- "- Status: "
tmp <- paste0(tmp0, "Whether the search encountered any problem for the two bounds. ",
"If no problem encountered, the code is 0 (displayed as 'OK'). Any value ",
"other than 0 indicates something was wrong in the search. ",
"Try running 'semlbci()' again, setting 'semlbci_out' to this output, ",
"and set 'try_k_more_times' to a positive number greater than ",
"2 (the default), e.g., 3 to 5.")
tmp <- strwrap(tmp,
indent = 0,
exdent = nchar(tmp0))
msg <- c(msg, tmp)
}
if (ratio_note) {
tmp0 <- "- Ratio: "
tmp <- paste0(tmp0,
"Ratio of a to b, ",
"a = Distance from the point estimate to a likelihood-based",
" confidence bound, b = Distance from the point estimate to the original",
" confidence bound. A bound should be interpreted with caution if",
" the ratio is too large or too small, indicating a large",
" difference between the original interval and the",
" likelihood-based interval.")
tmp <- strwrap(tmp,
indent = 0,
exdent = nchar(tmp0))
msg <- c(msg, tmp)
}
if (post_check_note) {
tmp0 <- "- Check: "
tmp <- paste0(tmp0,
"Whether the final solution of ",
"a confidence bound passed the post optimization check of lavaan ",
"by lavaan::lavInspect(fit, 'post.check'), where ",
"fit is the final solution.")
tmp <- strwrap(tmp,
indent = 0,
exdent = nchar(tmp0))
msg <- c(msg, tmp)
}
msg <- c("Likelihood-Based CI Notes:", "", msg)
# out <- append(out,
# msg,
# after = i1)
out <- c(msg, out)
}
if (!std) {
cat(out, sep = "\n")
return(invisible(x))
} else {
i <- grepl("Parameter Estimates:", out, fixed = TRUE)
out[i] <- "Standardized Estimates Only"
out <- gsub_heading(old = "\\s\\s\\s\\sEstimate",
new = "Standardized",
object = out)
cat(out, sep = "\n")
return(invisible(x))
}
}
#' @noRd
merge_attributes <- function(target, source) {
tmp1 <- names(attributes(source))
tmp2 <- names(attributes(target))
tmp3 <- setdiff(tmp1, tmp2)
if (length(tmp3) > 0) {
for (xx in tmp3) {
attr(target, xx) <- attr(source, xx)
}
}
target
}
#' @noRd
gsub_heading <- function(old,
new,
object) {
i1 <- grepl(old, object)
# i2 <- grepl("lbci", object)
# i <- i1 & i2
i <- i1
for (xx in which(i)) {
tmp <- object[i]
tmp <- gsub(old, new, tmp)
object[i] <- tmp
}
object
}
#' @noRd
verbose_needed <- function(x) {
call_org <- attr(x, "call")
if (is.null(call_org$ci_limit_ratio_tol)) {
ci_limit_ratio_tol <- formals(ci_bound_wn_i)$ci_limit_ratio_tol
} else {
ci_limit_ratio_tol <- call_org$ci_limit_ratio_tol
}
ratio_x <- c(x$ratio_lb, x$ratio_ub)
ratio_check_lb <- (x$ratio_lb > ci_limit_ratio_tol) |
(x$ratio_lb < 1 / ci_limit_ratio_tol)
ratio_check_ub <- (x$ratio_ub > ci_limit_ratio_tol) |
(x$ratio_ub < 1 / ci_limit_ratio_tol)
ratio_note <- any(ratio_x > ci_limit_ratio_tol, na.rm = TRUE) |
any(ratio_x < 1 / ci_limit_ratio_tol, na.rm = TRUE)
post_check_note <- !all(x$post_check_lb,
x$post_check_ub,
na.rm = TRUE)
status_note <- !all(x$status_lb == 0,
x$status_ub == 0,
na.rm = TRUE)
out <- list(ratio_note = ratio_note,
ratio_check_lb = ratio_check_lb,
ratio_check_ub = ratio_check_ub,
post_check_note = post_check_note,
status_note = status_note)
out
}
#' @noRd
format_status <- function(object) {
tmp <- character(length(object))
tmp[which(object == 0)] <- "OK"
i <- object != 0
tmp[which(i)] <- paste0("<", object[which(i)], ">")
tmp[is.na(object)] <- ""
tmp
}
#' @noRd
format_ratio <- function(object,
digits = 1,
flag,
where = c("left", "right", "none")) {
where <- match.arg(where)
tmp <- formatC(as.numeric(object),
digits = digits,
format = "f",
mode = "double")
tmp2 <- tmp
if (where == "left") {
tmp2[which(!flag)] <- paste0(" ", tmp[which(!flag)])
tmp2[which(flag)] <- paste0("<", tmp[which(flag)])
} else if (where == "right") {
tmp2[which(!flag)] <- paste0(tmp[which(!flag)], " ")
tmp2[which(flag)] <- paste0(tmp[which(flag)], ">")
}
tmp2[is.na(flag)] <- ""
tmp2
}
#' @noRd
format_post_check <- function(object) {
tmp <- character(length(object))
tmp[which(object)] <- "OK"
tmp[which(!object)] <- "Failed"
tmp[is.na(object)] <- ""
tmp
}
#' @noRd
compare_semlbci_sem_out <- function(semlbci_out,
sem_out) {
tmp1 <- lavaan::lav_partable_labels(semlbci_out)
ptable <- lavaan::parameterTable(sem_out)
tmp2 <- lavaan::lav_partable_labels(ptable)
out <- (length(setdiff(tmp1, tmp2)) == 0) &&
(length(setdiff(tmp2, tmp1)) == 0)
return(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.