diff --git a/DESCRIPTION b/DESCRIPTION
index 5773aa4..faa70f9 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,7 +1,7 @@
Package: psymetrics
Type: Package
Title: Unified Tools for Psychometric Model Analysis
-Version: 0.4.0
+Version: 0.5.0
Description: Provides tools for extracting and visualizing psychometric model fit indices,
compatible with various models like those from 'lavaan', 'psych', and 'mirt'.
Specific package dependencies are suggested and only required if using corresponding model objects.
@@ -24,6 +24,7 @@ Roxygen: list(markdown = TRUE)
RoxygenNote: 7.3.3
Imports:
cli,
+ ggplot2,
insight,
methods,
rlang,
@@ -31,10 +32,10 @@ Imports:
Suggests:
lavaan,
knitr,
- ggplot2,
flextable,
officer,
testthat (>= 3.0.0)
Depends:
R (>= 4.1.0)
Config/testthat/edition: 3
+
diff --git a/NAMESPACE b/NAMESPACE
index 3bacc5b..d9a49e2 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -14,11 +14,15 @@ S3method(model_estimates,default)
S3method(model_estimates,lavaan)
S3method(model_fit,default)
S3method(model_fit,lavaan)
+S3method(plot_model_fit,compare_model_fit)
+S3method(plot_model_fit,default)
+S3method(plot_model_fit,model_fit)
export(compare_model_estimates)
export(compare_model_fit)
export(format_results)
export(model_estimates)
export(model_fit)
export(plot_factor_loadings)
+export(plot_model_fit)
export(save_table)
importFrom(rlang,.data)
diff --git a/NEWS.md b/NEWS.md
index 2b7713c..c4d1ea1 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -1,3 +1,21 @@
+# psymetrics 0.5.0
+
+## New Features
+
+- **Fit plotting**: Added `plot_model_fit()` as a public plotting entrypoint for `model_fit` and `compare_model_fit` objects.
+- **Automatic defaults**: `type = "default"` now resolves to a single-fit bullet chart for `model_fit` objects and a threshold-aware dot plot for `compare_model_fit` objects.
+- **Multiple styles**: Added `bullet`, `dots`, `bars`, and `heatmap` plot styles for the approved `v0.5.0` workflows.
+- **Fit intervals**: RMSEA confidence intervals are now visualized automatically in styles that support them.
+- **Multi-row plotting**: `plot_model_fit()` now supports `model_fit` and `compare_model_fit` objects with multiple test rows per model via `test_mode`, and defaults to `dots` whenever a single-model summary expands beyond one plotted row.
+
+## Robustness, Testing & Docs
+
+- **Dependencies**: Moved `ggplot2` back to `Imports` so plotting APIs load as a supported core dependency rather than an optional add-on.
+- **Validation**: Plotting now validates supported classes, metrics, `test_mode`, and raw fitted-model inputs with clearer guidance.
+- **Fit metadata**: `model_fit()` and `compare_model_fit()` now store internal test-role metadata in attributes so downstream helpers such as `plot_model_fit()` can distinguish standard, non-standard, and primary test rows even when `TEST` is omitted from the visible table.
+- **Multi-test handling**: `bullet` is now reserved for single-row summaries, while `dots`, `bars`, and `heatmap` can visualize multiple tests or standard/non-standard variants from the same fit object.
+- **Testing**: Added dedicated tests for plotting defaults, style coverage, metric selection, CI handling, and non-converged objects.
+- **Documentation**: Added `plot_model_fit()` reference docs and updated README, pkgdown configuration, index, and roadmap entries for the new plotting workflow.
# psymetrics 0.4.0
## New Features
@@ -219,3 +237,5 @@
- The `NAMESPACE` file is now automatically managed using `roxygen2` to export the appropriate functions and maintain dependency order.
- Added a check in the examples to verify if `lavaan` is installed before running them.
+
+
diff --git a/R/compare_model_estimates-methods.R b/R/compare_model_estimates-methods.R
index 634bc13..bf25a88 100644
--- a/R/compare_model_estimates-methods.R
+++ b/R/compare_model_estimates-methods.R
@@ -52,7 +52,7 @@ prepare_table.compare_model_estimates <- function(x, digits = 3, ci_digits = dig
if (length(blocks) == 0L) {
empty_cols <- c(identity_cols, compare_model_estimates_default_display_cols(display_name_map))
empty_block <- as.data.frame(
- setNames(replicate(length(empty_cols), character(0), simplify = FALSE), empty_cols),
+ stats::setNames(replicate(length(empty_cols), character(0), simplify = FALSE), empty_cols),
stringsAsFactors = FALSE,
check.names = FALSE
)
@@ -245,7 +245,7 @@ compare_model_estimates_format_numeric_columns <- function(x, digits, ci_digits,
})
out <- as.data.frame(
- setNames(out, names(x)),
+ stats::setNames(out, names(x)),
stringsAsFactors = FALSE,
check.names = FALSE
)
diff --git a/R/compare_model_fit.R b/R/compare_model_fit.R
index c1a2e1d..92c8338 100644
--- a/R/compare_model_fit.R
+++ b/R/compare_model_fit.R
@@ -249,6 +249,8 @@ compare_model_fit <- function(..., type = NULL, metrics = "essential", verbose =
# Upper Text
names(combined_measures)[1] <- "MODEL"
+ combined_measures <- model_fit_bind_test_metadata(fit_measures, combined_measures)
+
# Assign the custom class for print method
class(combined_measures) <- c("compare_model_fit", class(combined_measures))
diff --git a/R/model_fit-lavaan.R b/R/model_fit-lavaan.R
index 5051dc4..5ec03eb 100644
--- a/R/model_fit-lavaan.R
+++ b/R/model_fit-lavaan.R
@@ -270,6 +270,16 @@ model_fit.lavaan <- function(fit, type = NULL, metrics = "essential", verbose =
selected_tests = selected_tests,
standard_test = standard_test
)
+ nonconverged_role <- if (isTRUE(standard_test) || length(selected_tests) == 0L) {
+ "standard"
+ } else {
+ "non_standard"
+ }
+ fit_measure <- model_fit_attach_test_metadata(
+ fit_measure,
+ test_role = rep(nonconverged_role, nrow(fit_measure)),
+ is_primary = rep(TRUE, nrow(fit_measure))
+ )
class(fit_measure) <- c("model_fit", class(fit_measure))
return(fit_measure)
}
@@ -278,6 +288,11 @@ model_fit.lavaan <- function(fit, type = NULL, metrics = "essential", verbose =
if (length(selected_tests) == 0L) {
if (type_forced_standard && !is_default_test && !isTRUE(standard_test)) {
fit_measure <- lavaan_empty_fit_measures(metrics, test_details = test_details)
+ fit_measure <- model_fit_attach_test_metadata(
+ fit_measure,
+ test_role = character(0),
+ is_primary = logical(0)
+ )
class(fit_measure) <- c("model_fit", class(fit_measure))
lavaan_emit_robust_warning(
robust_warning_collector,
@@ -297,6 +312,11 @@ model_fit.lavaan <- function(fit, type = NULL, metrics = "essential", verbose =
robust_warning_collector = robust_warning_collector,
model_label = model_label
)
+ fit_measure <- model_fit_attach_test_metadata(
+ fit_measure,
+ test_role = rep("standard", nrow(fit_measure)),
+ is_primary = rep(TRUE, nrow(fit_measure))
+ )
lavaan_emit_robust_warning(
robust_warning_collector,
verbose = verbose,
@@ -343,6 +363,19 @@ model_fit.lavaan <- function(fit, type = NULL, metrics = "essential", verbose =
}
fit_measure <- do.call(rbind, fit_measure_list)
+ test_role <- c(
+ if (isTRUE(standard_test)) "standard",
+ rep("non_standard", length(selected_tests))
+ )
+ is_primary <- c(
+ if (isTRUE(standard_test)) FALSE,
+ c(TRUE, rep(FALSE, max(length(selected_tests) - 1L, 0L)))
+ )
+ fit_measure <- model_fit_attach_test_metadata(
+ fit_measure,
+ test_role = test_role,
+ is_primary = is_primary
+ )
class(fit_measure) <- unique(c("model_fit", class(fit_measure)))
lavaan_emit_robust_warning(
robust_warning_collector,
@@ -621,6 +654,83 @@ extract_fit_lavaan <- function(fit, type, metrics, verbose,
# Helper functions ------------------------------------------------------------
+model_fit_metadata_row_keys <- function(x) {
+ keys <- rownames(x)
+ if (is.null(keys) || length(keys) != nrow(x)) {
+ keys <- as.character(seq_len(nrow(x)))
+ }
+ keys
+}
+
+model_fit_attach_test_metadata <- function(x, test_role, is_primary) {
+ n <- nrow(x)
+ if (length(test_role) != n) {
+ rlang::abort("`test_role` metadata must have one entry per row.")
+ }
+ if (length(is_primary) != n) {
+ rlang::abort("`is_primary` metadata must have one entry per row.")
+ }
+
+ row_keys <- model_fit_metadata_row_keys(x)
+
+ test_role <- as.character(test_role)
+ names(test_role) <- row_keys
+
+ is_primary <- as.logical(is_primary)
+ names(is_primary) <- row_keys
+
+ attr(x, "psymetrics_test_role") <- test_role
+ attr(x, "psymetrics_test_primary") <- is_primary
+ x
+}
+
+model_fit_resolve_row_metadata <- function(x, attr_name, default) {
+ meta <- attr(x, attr_name, exact = TRUE)
+ if (is.null(meta)) {
+ return(default)
+ }
+
+ row_keys <- model_fit_metadata_row_keys(x)
+ out <- default
+
+ if (!is.null(names(meta))) {
+ match_idx <- match(row_keys, names(meta))
+ matched <- !is.na(match_idx)
+ out[matched] <- unname(meta[match_idx[matched]])
+ return(out)
+ }
+
+ if (length(meta) == nrow(x)) {
+ out[] <- unname(meta)
+ }
+
+ out
+}
+
+model_fit_get_test_role <- function(x) {
+ default <- stats::setNames(rep(NA_character_, nrow(x)), model_fit_metadata_row_keys(x))
+ model_fit_resolve_row_metadata(x, "psymetrics_test_role", default)
+}
+
+model_fit_get_test_primary <- function(x) {
+ default <- stats::setNames(rep(NA, nrow(x)), model_fit_metadata_row_keys(x))
+ model_fit_resolve_row_metadata(x, "psymetrics_test_primary", default)
+}
+
+model_fit_bind_test_metadata <- function(objects, combined) {
+ test_role <- unlist(lapply(objects, model_fit_get_test_role), use.names = FALSE)
+ is_primary <- unlist(lapply(objects, model_fit_get_test_primary), use.names = FALSE)
+
+ if (length(test_role) != nrow(combined)) {
+ test_role <- rep(NA_character_, nrow(combined))
+ }
+ if (length(is_primary) != nrow(combined)) {
+ is_primary <- rep(NA, nrow(combined))
+ }
+
+ model_fit_attach_test_metadata(combined, test_role = test_role, is_primary = is_primary)
+}
+
lavaan_init_robust_warning_collector <- function(collector = NULL) {
if (is.null(collector)) {
collector <- new.env(parent = emptyenv())
diff --git a/R/plot-lavaan.R b/R/plot-lavaan.R
index 4aec290..615c865 100644
--- a/R/plot-lavaan.R
+++ b/R/plot-lavaan.R
@@ -32,9 +32,9 @@
#' plotting functions.
#'
#' @return A ggplot object for `factor_loadings` and `residuals`
-#' plots if `ggplot2` is installed, or a `semPlot` diagram
-#' object for `path` plots. An error message will be returned
-#' if required packages are not available.
+#' plots, or a `semPlot` diagram object for `path` plots.
+#' An error message will be returned if other required packages
+#' are not available.
#' @details
#' - **Factor Loadings Plot**: Displays a dot plot of factor
#' loadings (`=~` parameters only), with items on the y-axis
@@ -52,8 +52,7 @@
#' for type = "factor_loadings".
#' @exportS3Method graphics::plot lavaan
#' @examples
-#' if (requireNamespace("lavaan", quietly = TRUE) &&
-#' requireNamespace("ggplot2", quietly = TRUE)) {
+#' if (requireNamespace("lavaan", quietly = TRUE)) {
#' library(lavaan)
#' library(psymetrics)
#' hs_model <- 'visual =~ x1 + x2 + x3
@@ -61,8 +60,6 @@
#' speed =~ x7 + x8 + x9'
#' fit <- cfa(hs_model, data = HolzingerSwineford1939, estimator = "MLR")
#' plot(fit)
-#' } else {
-#' message("Please install 'lavaan' and 'ggplot2' to run this example.")
#' }
plot.lavaan <- function(x, type = "factor_loadings", standardized = TRUE, ci = TRUE, ...) {
rlang::check_installed("lavaan", reason = "to process 'lavaan' objects.")
@@ -144,16 +141,14 @@ plot.lavaan <- function(x, type = "factor_loadings", standardized = TRUE, ci = T
#' errors are still raised.
#' @param ... Additional arguments passed to `ggplot2::ggplot`.
#'
-#' @return A ggplot object if `ggplot2` is installed, otherwise
-#' an error message.
+#' @return A ggplot object.
#' @seealso
#' - [plot-methods] for an overview of plotting in the package.
#' - [plot.lavaan()] for more lavaan object plots.
#' @importFrom rlang .data
#' @export
#' @examples
-#' if (requireNamespace("lavaan", quietly = TRUE) &&
-#' requireNamespace("ggplot2", quietly = TRUE)) {
+#' if (requireNamespace("lavaan", quietly = TRUE)) {
#' library(lavaan)
#' library(psymetrics)
#' hs_model <- 'visual =~ x1 + x2 + x3
@@ -168,8 +163,6 @@ plot.lavaan <- function(x, type = "factor_loadings", standardized = TRUE, ci = T
#' speed ~ textual'
#' fit_sem <- sem(sem_model, data = HolzingerSwineford1939, group = "school")
#' plot_factor_loadings(fit_sem, facet_by = "group")
-#' } else {
-#' message("Please install 'lavaan' and 'ggplot2' to run this example.")
#' }
plot_factor_loadings <- function(fit,
sort = TRUE,
@@ -182,7 +175,6 @@ plot_factor_loadings <- function(fit,
verbose = TRUE,
...) {
rlang::check_installed("lavaan", reason = "to process 'lavaan' objects.")
- rlang::check_installed("ggplot2", reason = "to create dot plots for factor loadings")
if (!inherits(fit, "lavaan")) {
cli::cli_abort("The {.arg fit} argument must be a fitted {.cls lavaan} object.")
}
diff --git a/R/plot_model_fit-helpers.R b/R/plot_model_fit-helpers.R
new file mode 100644
index 0000000..211e956
--- /dev/null
+++ b/R/plot_model_fit-helpers.R
@@ -0,0 +1,1232 @@
+plot_model_fit_supported_metrics <- function() {
+ c("CFI", "TLI", "RMSEA", "SRMR")
+}
+
+plot_model_fit_metric_spec <- function(metrics = NULL) {
+ spec <- data.frame(
+ Metric = plot_model_fit_supported_metrics(),
+ Direction = c("higher", "higher", "lower", "lower"),
+ Good = c(0.90, 0.90, 0.08, 0.08),
+ Ideal = c(0.95, 0.95, 0.05, 0.06),
+ Poor = c(0.80, 0.80, 0.12, 0.12),
+ Primary = c(0.95, 0.90, 0.08, 0.05),
+ AxisMin = c(0.80, 0.80, 0.00, 0.00),
+ AxisMax = c(1.00, 1.00, 0.15, 0.15),
+ Panel = c(
+ "Incremental fit (CFI & TLI)",
+ "Incremental fit (CFI & TLI)",
+ "Approximation error (RMSEA & SRMR)",
+ "Approximation error (RMSEA & SRMR)"
+ ),
+ ShowInterval = c(FALSE, FALSE, TRUE, FALSE),
+ IntervalLowCol = c(NA_character_, NA_character_, "RMSEA_CI_low", NA_character_),
+ IntervalHighCol = c(NA_character_, NA_character_, "RMSEA_CI_high", NA_character_),
+ stringsAsFactors = FALSE
+ )
+
+ if (is.null(metrics)) {
+ return(spec)
+ }
+
+ spec[match(metrics, spec$Metric), , drop = FALSE]
+}
+
+plot_model_fit_model_palette <- function(n_models) {
+ base_palette <- c("#2aa198", "#d1a013", "#7b6db6", "#d95f5f", "#4f8ad9", "#7f9f3f")
+ if (n_models <= length(base_palette)) {
+ return(base_palette[seq_len(n_models)])
+ }
+ grDevices::hcl.colors(n_models, palette = "Dynamic")
+}
+
+plot_model_fit_variant_shapes <- function(n_variants) {
+ base_shapes <- c(16, 17, 15, 18, 8, 3, 7, 9)
+ if (n_variants <= length(base_shapes)) {
+ return(base_shapes[seq_len(n_variants)])
+ }
+ rep(base_shapes, length.out = n_variants)
+}
+
+plot_model_fit_density_scale <- function(n_items, reference, min_scale = 0.85, max_scale = 1.15) {
+ if (!is.numeric(n_items) || length(n_items) != 1L || is.na(n_items) || n_items <= 0) {
+ return(1)
+ }
+ scale <- reference / n_items
+ min(max(scale, min_scale), max_scale)
+}
+
+plot_model_fit_pt <- function(points) {
+ points / ggplot2::.pt
+}
+
+plot_model_fit_halo_text_grob <- function(label, x, y, just, col, fontsize, family = "", fontface = 1, lineheight = 1.2, halo_mm = 0.30, halo_col = "#E7E7E7", halo_alpha = 0.96) {
+ offsets <- list(
+ c(-1, 0), c(1, 0), c(0, -1), c(0, 1),
+ c(-1, -1), c(-1, 1), c(1, -1), c(1, 1)
+ )
+ halo_grobs <- lapply(offsets, function(offset) {
+ grid::textGrob(
+ label = label,
+ x = x + grid::unit(offset[1] * halo_mm, "mm"),
+ y = y + grid::unit(offset[2] * halo_mm, "mm"),
+ just = just,
+ gp = grid::gpar(
+ col = grDevices::adjustcolor(halo_col, alpha.f = halo_alpha),
+ fontsize = fontsize,
+ fontfamily = family,
+ fontface = fontface,
+ lineheight = lineheight
+ )
+ )
+ })
+ main_grob <- grid::textGrob(
+ label = label,
+ x = x,
+ y = y,
+ just = just,
+ gp = grid::gpar(
+ col = col,
+ fontsize = fontsize,
+ fontfamily = family,
+ fontface = fontface,
+ lineheight = lineheight
+ )
+ )
+ do.call(grid::grobTree, c(halo_grobs, list(main_grob)))
+}
+
+GeomPlotModelFitBarMarker <- ggplot2::ggproto(
+ 'GeomPlotModelFitBarMarker',
+ ggplot2::Geom,
+ required_aes = c('x', 'y', 'shape_code'),
+ default_aes = ggplot2::aes(alpha = 1, placement = "inside", inside_scale = 1),
+ draw_key = ggplot2::draw_key_blank,
+ draw_panel = function(data, panel_params, coord, size = 2.8, stroke = 0.7, colour = '#202020', fill = '#202020', gap_mm = 0.9, tall_gap_mm = 0.35) {
+ if (nrow(data) == 0L) {
+ return(grid::nullGrob())
+ }
+
+ coords <- coord$transform(data, panel_params)
+ tall_shape <- is.finite(coords$shape_code) & coords$shape_code %in% c(17, 24, 25)
+ gap_vec <- gap_mm + ifelse(tall_shape, tall_gap_mm, 0)
+ placement_vec <- if ("placement" %in% names(coords)) as.character(coords$placement) else rep("inside", nrow(coords))
+ inside_scale <- if ("inside_scale" %in% names(coords)) coords$inside_scale else rep(1, nrow(coords))
+ y_adjust_mm <- ifelse(placement_vec == "inside", -(gap_vec + size / 2) * inside_scale, 0)
+
+ grid::pointsGrob(
+ x = grid::unit(coords$x, 'npc'),
+ y = grid::unit(coords$y, 'npc') + grid::unit(y_adjust_mm, 'mm'),
+ pch = coords$shape_code,
+ size = grid::unit(rep(size, nrow(coords)), 'mm'),
+ gp = grid::gpar(
+ col = colour,
+ fill = fill,
+ lwd = stroke * ggplot2::.stroke
+ )
+ )
+ }
+)
+
+plot_model_fit_geom_bar_marker <- function(mapping = NULL, data = NULL, ..., size = 2.8, stroke = 0.7, colour = '#202020', fill = '#202020', gap_mm = 0.9, tall_gap_mm = 0.35, na.rm = FALSE, show.legend = FALSE, inherit.aes = FALSE) {
+ ggplot2::layer(
+ geom = GeomPlotModelFitBarMarker,
+ mapping = mapping,
+ data = data,
+ stat = 'identity',
+ position = 'identity',
+ show.legend = show.legend,
+ inherit.aes = inherit.aes,
+ params = list(
+ size = size,
+ stroke = stroke,
+ colour = colour,
+ fill = fill,
+ gap_mm = gap_mm,
+ tall_gap_mm = tall_gap_mm,
+ na.rm = na.rm,
+ ...
+ )
+ )
+}
+
+GeomPlotModelFitPlainLabel <- ggplot2::ggproto(
+ 'GeomPlotModelFitPlainLabel',
+ ggplot2::Geom,
+ required_aes = c('x', 'y', 'label'),
+ default_aes = ggplot2::aes(colour = '#202020', alpha = 1),
+ draw_key = ggplot2::draw_key_blank,
+ draw_panel = function(data, panel_params, coord, size = 3.8, point_size = 5.1, gap_mm = 0.8, family = '', fontface = 1, lineheight = 1.2, text_colour = '#1f1f1f') {
+ if (nrow(data) == 0L) {
+ return(grid::nullGrob())
+ }
+
+ coords <- coord$transform(data, panel_params)
+ alpha_vec <- if ("alpha" %in% names(coords)) coords$alpha else rep(1, nrow(coords))
+ col_vec <- mapply(function(col, alpha) grDevices::adjustcolor(col, alpha.f = alpha), coords$colour, alpha_vec, USE.NAMES = FALSE)
+ text_col_vec <- rep(text_colour, length.out = nrow(coords))
+ text_y <- grid::unit(coords$y, "npc") + grid::unit(point_size / 2 + gap_mm, "mm")
+ fontsize <- size * ggplot2::.pt
+ text_grobs <- lapply(seq_len(nrow(coords)), function(i) {
+ plot_model_fit_halo_text_grob(
+ label = coords$label[i],
+ x = grid::unit(coords$x[i], "npc"),
+ y = text_y[i],
+ just = c("centre", "bottom"),
+ col = text_col_vec[i],
+ fontsize = fontsize,
+ family = family,
+ fontface = fontface,
+ lineheight = lineheight
+ )
+ })
+ do.call(grid::grobTree, text_grobs)
+ }
+)
+
+plot_model_fit_geom_plain_label <- function(mapping = NULL, data = NULL, ..., size = 3.8, point_size = 5.1, gap_mm = 0.8, family = '', fontface = 1, lineheight = 1.2, text_colour = '#1f1f1f', na.rm = FALSE, show.legend = FALSE, inherit.aes = FALSE) {
+ ggplot2::layer(
+ geom = GeomPlotModelFitPlainLabel,
+ mapping = mapping,
+ data = data,
+ stat = 'identity',
+ position = 'identity',
+ show.legend = show.legend,
+ inherit.aes = inherit.aes,
+ params = list(
+ size = size,
+ point_size = point_size,
+ gap_mm = gap_mm,
+ family = family,
+ fontface = fontface,
+ lineheight = lineheight,
+ text_colour = text_colour,
+ na.rm = na.rm,
+ ...
+ )
+ )
+}
+
+GeomPlotModelFitDotCallout <- ggplot2::ggproto(
+ 'GeomPlotModelFitDotCallout',
+ ggplot2::Geom,
+ required_aes = c('x', 'y', 'label'),
+ default_aes = ggplot2::aes(colour = '#202020', alpha = 1, hjust = 0),
+ draw_key = ggplot2::draw_key_blank,
+ draw_panel = function(data, panel_params, coord, size = 3.8, point_size = 5.1, label_dx_mm = 1.95, label_dy_mm = 1.45, anchor_rise_mm = 0.75, arrow_mm = 0.90, linewidth = 0.72, family = '', fontface = 1, lineheight = 1.2, text_colour = '#1f1f1f') {
+ if (nrow(data) == 0L) {
+ return(grid::nullGrob())
+ }
+
+ coords <- coord$transform(data, panel_params)
+ alpha_vec <- if ('alpha' %in% names(coords)) coords$alpha else rep(1, nrow(coords))
+ col_vec <- mapply(function(col, alpha) grDevices::adjustcolor(col, alpha.f = alpha), coords$colour, alpha_vec, USE.NAMES = FALSE)
+ text_col_vec <- rep(text_colour, length.out = nrow(coords))
+ hjust_vec <- if ('hjust' %in% names(data)) data$hjust else rep(0, nrow(data))
+ direction <- ifelse(hjust_vec > 0.5, -1, 1)
+ text_x <- grid::unit(coords$x, 'npc') + grid::unit(direction * (point_size / 2 + label_dx_mm), 'mm')
+ text_y <- grid::unit(coords$y, 'npc') + grid::unit(label_dy_mm, 'mm')
+ seg_x0 <- grid::unit(coords$x, 'npc') + grid::unit(direction * (point_size / 2 - 0.1), 'mm')
+ seg_y0 <- grid::unit(coords$y, 'npc') + grid::unit(anchor_rise_mm, 'mm')
+ seg_x1 <- text_x - grid::unit(direction * 0.55, 'mm')
+ seg_y1 <- text_y - grid::unit(0.55, 'mm')
+ text_grobs <- lapply(seq_len(nrow(coords)), function(i) {
+ plot_model_fit_halo_text_grob(
+ label = coords$label[i],
+ x = text_x[i],
+ y = text_y[i],
+ just = c(if (direction[i] > 0) "left" else "right", "bottom"),
+ col = text_col_vec[i],
+ fontsize = size * ggplot2::.pt,
+ family = family,
+ fontface = fontface,
+ lineheight = lineheight
+ )
+ })
+
+ do.call(
+ grid::grobTree,
+ c(
+ list(
+ grid::segmentsGrob(
+ x0 = seg_x0,
+ y0 = seg_y0,
+ x1 = seg_x1,
+ y1 = seg_y1,
+ gp = grid::gpar(col = col_vec, lwd = linewidth * ggplot2::.stroke),
+ arrow = grid::arrow(length = grid::unit(arrow_mm, 'mm'), type = 'closed')
+ )
+ ),
+ text_grobs
+ )
+ )
+ }
+)
+
+plot_model_fit_geom_dot_callout <- function(mapping = NULL, data = NULL, ..., size = 3.8, point_size = 5.1, label_dx_mm = 1.95, label_dy_mm = 1.45, anchor_rise_mm = 0.75, arrow_mm = 0.90, linewidth = 0.72, family = '', fontface = 1, lineheight = 1.2, text_colour = '#1f1f1f', na.rm = FALSE, show.legend = FALSE, inherit.aes = FALSE) {
+ ggplot2::layer(
+ geom = GeomPlotModelFitDotCallout,
+ mapping = mapping,
+ data = data,
+ stat = 'identity',
+ position = 'identity',
+ show.legend = show.legend,
+ inherit.aes = inherit.aes,
+ params = list(
+ size = size,
+ point_size = point_size,
+ label_dx_mm = label_dx_mm,
+ label_dy_mm = label_dy_mm,
+ anchor_rise_mm = anchor_rise_mm,
+ arrow_mm = arrow_mm,
+ linewidth = linewidth,
+ family = family,
+ fontface = fontface,
+ lineheight = lineheight,
+ text_colour = text_colour,
+ na.rm = na.rm,
+ ...
+ )
+ )
+}
+plot_model_fit_size_spec <- function(style, n_metrics = 4L, n_rows = 1L) {
+ style <- match.arg(style, c("bullet", "dots", "bars", "heatmap"))
+ metric_scale <- plot_model_fit_density_scale(n_metrics, reference = 4, min_scale = 0.92, max_scale = 1.10)
+ row_scale <- plot_model_fit_density_scale(n_rows, reference = 3, min_scale = 0.85, max_scale = 1.10)
+ compact_scale <- min(metric_scale, row_scale)
+
+ common <- list(
+ metric_scale = metric_scale,
+ row_scale = row_scale,
+ compact_scale = compact_scale
+ )
+
+ utils::modifyList(
+ common,
+ switch(
+ style,
+ bullet = list(
+ base = 15,
+ title = 20,
+ subtitle = 14.5,
+ strip = 17,
+ value_pt = 10.0 * compact_scale,
+ tick_pt = 8.6 * metric_scale,
+ cutoff_pt = 9.2 * metric_scale,
+ tick_y = 0.72,
+ band_padding = 0.02 * metric_scale,
+ callout_curve_linewidth = 0.78 * compact_scale,
+ callout_arrow_mm = 1.10 * compact_scale,
+ callout_label_dx_mm = 2.25 * compact_scale,
+ callout_label_dy_mm = 1.90 * compact_scale,
+ callout_anchor_rise_mm = 0.95 * compact_scale
+ ),
+ dots = list(
+ base = 14.5,
+ title = 19,
+ subtitle = 14,
+ strip = 13.8,
+ axis_y = 11.4,
+ value_pt = 10.2 * compact_scale,
+ tick_pt = 9.4 * metric_scale,
+ cutoff_pt = 9.9 * metric_scale,
+ legend_pt = 11.2,
+ data_ymin = 0.72,
+ data_ymax_pad = 0.42 * row_scale,
+ y_lower = 0.18,
+ y_upper_pad = 0.72 * row_scale,
+ callout_curve_linewidth = 0.72 * compact_scale,
+ callout_arrow_mm = 0.90 * compact_scale,
+ callout_label_dx_mm = 1.95 * compact_scale,
+ callout_label_dy_mm = 1.45 * compact_scale,
+ callout_anchor_rise_mm = 0.75 * compact_scale,
+ tick_y = 0.34
+ ),
+ bars = list(
+ base = 14.5,
+ title = 19,
+ subtitle = 14,
+ strip = 13.5,
+ axis_y = 11.4,
+ value_pt = 10.8 * compact_scale,
+ threshold_pt = 9.9 * metric_scale,
+ metric_pt = 10.2,
+ legend_pt = 11.2,
+ upper_label_offset = 0.0018 + 0.0008 * compact_scale,
+ lower_label_offset = 0.0014 + 0.0006 * compact_scale,
+ label_padding = 0.0055 + 0.0015 * compact_scale,
+ label_radius = 0.015,
+ variant_marker_size = 2.7 + 0.25 * compact_scale,
+ variant_marker_stroke = 0.7,
+ threshold_panel_offset = 0.003 + 0.0015 * compact_scale,
+ threshold_stack_offset = 0.002 + 0.0010 * compact_scale,
+ axis_panel_offset = 0.014 + 0.004 * compact_scale
+ ),
+ heatmap = list(
+ base = 14.5,
+ title = 20,
+ subtitle = 14.5,
+ axis_pt = 14.5 * metric_scale,
+ cell_pt = 11.5 * compact_scale,
+ legend_title_pt = 12.2,
+ legend_text_pt = 11.2
+ )
+ )
+ )
+}
+
+plot_model_fit_validate_input <- function(x) {
+ if (inherits(x, "compare_model_fit")) {
+ if (!"MODEL" %in% names(x)) {
+ cli::cli_abort("`compare_model_fit` objects must contain a `MODEL` column.")
+ }
+ return("compare_model_fit")
+ }
+
+ if (inherits(x, "model_fit")) {
+ return("model_fit")
+ }
+
+ fit_class <- class(x)
+ if (is.null(fit_class) || length(fit_class) == 0L) {
+ fit_class <- typeof(x)
+ }
+ fit_class <- paste(fit_class, collapse = ", ")
+
+ cli::cli_abort(c(
+ sprintf("Objects of class '%s' are not currently supported by `plot_model_fit()`.", fit_class),
+ "`plot_model_fit()` requires a `model_fit` or `compare_model_fit` object, not a raw fitted model.",
+ "For one fitted model, call `model_fit(fit)` first.",
+ "For multiple fitted models, call `compare_model_fit(...)` first."
+ ))
+}
+
+plot_model_fit_resolve_test_mode <- function(test_mode) {
+ supported <- c("all", "non_standard", "standard_only", "primary")
+
+ if (!is.character(test_mode) || length(test_mode) != 1L || is.na(test_mode)) {
+ cli::cli_abort("`test_mode` must be a single character string.")
+ }
+
+ test_mode <- trimws(test_mode)
+ if (!test_mode %in% supported) {
+ cli::cli_abort(c(
+ sprintf("Unsupported `test_mode = '%s'`.", test_mode),
+ sprintf("Supported values: %s.", paste(supported, collapse = ", "))
+ ))
+ }
+
+ test_mode
+}
+
+plot_model_fit_resolve_type <- function(type, input_class, n_rows) {
+ supported <- c("default", "bullet", "dots", "bars", "heatmap")
+
+ if (!is.character(type) || length(type) != 1L || is.na(type)) {
+ cli::cli_abort("`type` must be a single character string.")
+ }
+
+ type <- trimws(type)
+
+ if (!type %in% supported) {
+ cli::cli_abort(c(
+ sprintf("Unsupported `type = '%s'` for `%s` objects.", type, input_class),
+ sprintf("Supported values: %s.", paste(supported, collapse = ", "))
+ ))
+ }
+
+ if (type == "default") {
+ if (identical(input_class, "model_fit") && n_rows == 1L) {
+ return("bullet")
+ }
+ return("dots")
+ }
+
+ type
+}
+
+plot_model_fit_resolve_metrics <- function(x, metrics = NULL, verbose = TRUE) {
+ supported <- plot_model_fit_supported_metrics()
+
+ if (is.null(metrics)) {
+ selected <- supported[supported %in% names(x)]
+ if (length(selected) == 0L) {
+ cli::cli_abort("No supported fit indices are available to plot.")
+ }
+ return(selected)
+ }
+
+ if (!is.character(metrics) || length(metrics) == 0L) {
+ cli::cli_abort("`metrics` must be NULL or a non-empty character vector.")
+ }
+
+ metrics <- toupper(trimws(metrics))
+ metrics <- metrics[metrics != ""]
+ metrics <- unique(metrics)
+ unknown <- setdiff(metrics, supported)
+ if (length(unknown) > 0L) {
+ cli::cli_abort(c(
+ sprintf(
+ "Unsupported metric name%s: %s.",
+ if (length(unknown) > 1L) "s" else "",
+ paste(unknown, collapse = ", ")
+ ),
+ sprintf("Supported metrics: %s.", paste(supported, collapse = ", "))
+ ))
+ }
+
+ available <- metrics[metrics %in% names(x)]
+ dropped <- setdiff(metrics, available)
+ if (length(dropped) > 0L && isTRUE(verbose)) {
+ cli::cli_inform(
+ "Requested metrics not present in the object were dropped: {dropped}."
+ )
+ }
+ if (length(available) == 0L) {
+ cli::cli_abort("None of the requested metrics are available in the object.")
+ }
+
+ available
+}
+
+plot_model_fit_prepare_single_df <- function(x, metrics) {
+ keep <- unique(c(metrics, "RMSEA_CI_low", "RMSEA_CI_high", "TEST", "ESTIMATOR"))
+ keep <- keep[keep %in% names(x)]
+ data.frame(
+ MODEL_BASE = "Model",
+ x[, keep, drop = FALSE],
+ check.names = FALSE,
+ stringsAsFactors = FALSE
+ )
+}
+
+plot_model_fit_prepare_compare_df <- function(x, metrics) {
+ keep <- unique(c("MODEL", metrics, "RMSEA_CI_low", "RMSEA_CI_high", "TEST", "ESTIMATOR"))
+ keep <- keep[keep %in% names(x)]
+ out <- x[, keep, drop = FALSE]
+ out$MODEL_BASE <- as.character(out$MODEL)
+ out$MODEL <- NULL
+ out
+}
+
+plot_model_fit_rows_by_model <- function(model_base) {
+ split(seq_along(model_base), factor(model_base, levels = unique(model_base)))
+}
+
+plot_model_fit_metadata_values <- function(df, source, getter) {
+ out <- rep(NA, nrow(df))
+ if (nrow(df) == 0L || is.null(source)) {
+ return(out)
+ }
+
+ meta <- getter(source)
+ if (length(meta) == 0L) {
+ return(out)
+ }
+
+ row_keys <- model_fit_metadata_row_keys(df)
+ out[] <- unname(meta[row_keys])
+ out
+}
+
+plot_model_fit_is_standard_row <- function(df, source = NULL) {
+ out <- rep(NA, nrow(df))
+ if (nrow(df) == 0L) {
+ return(out)
+ }
+
+ metadata_role <- plot_model_fit_metadata_values(
+ df,
+ source = source,
+ getter = model_fit_get_test_role
+ )
+ known <- !is.na(metadata_role)
+ out[known] <- metadata_role[known] == "standard"
+
+ out
+}
+
+plot_model_fit_is_primary_row <- function(df, source = NULL) {
+ out <- rep(NA, nrow(df))
+ if (nrow(df) == 0L) {
+ return(out)
+ }
+
+ metadata_primary <- plot_model_fit_metadata_values(
+ df,
+ source = source,
+ getter = model_fit_get_test_primary
+ )
+ known <- !is.na(metadata_primary)
+ out[known] <- metadata_primary[known]
+
+ out
+}
+
+plot_model_fit_validate_test_metadata <- function(df, test_mode) {
+ if (nrow(df) == 0L || identical(test_mode, "all")) {
+ return(invisible(NULL))
+ }
+
+ rows_by_model <- plot_model_fit_rows_by_model(df$MODEL_BASE)
+
+ for (idx in rows_by_model) {
+ model_df <- df[idx, , drop = FALSE]
+ if (test_mode %in% c("non_standard", "standard_only") && any(is.na(model_df$IS_STANDARD))) {
+ cli::cli_abort(c(
+ "This fit object does not contain the internal test metadata required for `test_mode` filtering.",
+ "Recreate it with the current `model_fit()` or `compare_model_fit()` implementation."
+ ))
+ }
+
+ if (identical(test_mode, "primary") && any(is.na(model_df$IS_PRIMARY))) {
+ cli::cli_abort(c(
+ "This fit object does not contain the internal primary-test metadata required for `test_mode = 'primary'`.",
+ "Recreate it with the current `model_fit()` or `compare_model_fit()` implementation."
+ ))
+ }
+ }
+
+ invisible(NULL)
+}
+
+plot_model_fit_variant_labels <- function(df) {
+ n <- nrow(df)
+ if (n == 0L) {
+ return(character(0))
+ }
+
+ variant <- rep(NA_character_, n)
+ if ("TEST" %in% names(df)) {
+ variant <- trimws(as.character(df$TEST))
+ variant[variant == ""] <- NA_character_
+ }
+
+ estimator_label <- rep(NA_character_, n)
+ if ("ESTIMATOR" %in% names(df)) {
+ estimator_label <- trimws(as.character(df$ESTIMATOR))
+ estimator_label[estimator_label == ""] <- NA_character_
+ }
+
+ need_estimator <- is.na(variant)
+ variant[need_estimator] <- estimator_label[need_estimator]
+
+ row_labels <- paste0("Row ", seq_len(n))
+ variant[is.na(variant)] <- row_labels[is.na(variant)]
+
+ duplicated_variant <- duplicated(variant) | duplicated(variant, fromLast = TRUE)
+ if (any(duplicated_variant)) {
+ dup_index <- stats::ave(seq_len(n), variant, FUN = seq_along)
+ variant[duplicated_variant] <- paste0(variant[duplicated_variant], " (Row ", dup_index[duplicated_variant], ")")
+ }
+
+ variant
+}
+
+plot_model_fit_apply_test_mode <- function(df, test_mode) {
+ if (nrow(df) == 0L) {
+ return(df)
+ }
+
+ rows_by_model <- plot_model_fit_rows_by_model(df$MODEL_BASE)
+ keep_idx <- integer(0)
+
+ for (idx in rows_by_model) {
+ model_df <- df[idx, , drop = FALSE]
+ standard_idx <- which(model_df$IS_STANDARD %in% TRUE)
+ non_standard_idx <- setdiff(seq_len(nrow(model_df)), standard_idx)
+ primary_idx <- which(model_df$IS_PRIMARY %in% TRUE)
+
+ selected_idx <- switch(
+ test_mode,
+ all = seq_len(nrow(model_df)),
+ non_standard = non_standard_idx,
+ standard_only = standard_idx,
+ primary = if (length(primary_idx) > 0L) primary_idx[1] else integer(0)
+ )
+
+ if (length(selected_idx) > 0L) {
+ keep_idx <- c(keep_idx, idx[selected_idx])
+ }
+ }
+
+ df[keep_idx, , drop = FALSE]
+}
+
+plot_model_fit_finalize_plot_rows <- function(df) {
+ if (nrow(df) == 0L) {
+ return(df)
+ }
+
+ rows_by_model <- plot_model_fit_rows_by_model(df$MODEL_BASE)
+ variant <- character(nrow(df))
+ plot_id <- character(nrow(df))
+
+ for (idx in rows_by_model) {
+ model_df <- df[idx, , drop = FALSE]
+ model_variant <- plot_model_fit_variant_labels(model_df)
+ variant[idx] <- model_variant
+ if (length(idx) == 1L) {
+ plot_id[idx] <- model_df$MODEL_BASE[1]
+ } else {
+ plot_id[idx] <- paste0(model_df$MODEL_BASE, " | ", model_variant)
+ }
+ }
+
+ df$VARIANT <- variant
+ df$PLOT_ID <- plot_id
+ df$PLOT_ORDER <- seq_len(nrow(df))
+ df
+}
+
+plot_model_fit_prepare_data <- function(x, metrics, input_class, test_mode) {
+ out <- if (identical(input_class, "model_fit")) {
+ plot_model_fit_prepare_single_df(x, metrics)
+ } else {
+ plot_model_fit_prepare_compare_df(x, metrics)
+ }
+
+ out$MODEL_BASE <- as.character(out$MODEL_BASE)
+ out$IS_STANDARD <- plot_model_fit_is_standard_row(out, source = x)
+ out$IS_PRIMARY <- plot_model_fit_is_primary_row(out, source = x)
+ out$ROW_IN_MODEL <- stats::ave(seq_len(nrow(out)), out$MODEL_BASE, FUN = seq_along)
+ plot_model_fit_validate_test_metadata(out, test_mode)
+ out <- plot_model_fit_apply_test_mode(out, test_mode)
+
+ if (nrow(out) == 0L) {
+ cli::cli_abort(c(
+ sprintf("`test_mode = '%s'` left no rows available to plot.", test_mode),
+ "Choose a different `test_mode` or create a fit table with compatible test rows."
+ ))
+ }
+
+ plot_model_fit_finalize_plot_rows(out)
+}
+
+plot_model_fit_extract_interval_df <- function(fit_df, metric_spec) {
+ interval_metrics <- metric_spec[metric_spec$ShowInterval, , drop = FALSE]
+ if (nrow(interval_metrics) == 0L) {
+ return(NULL)
+ }
+
+ rows <- lapply(seq_len(nrow(interval_metrics)), function(i) {
+ row <- interval_metrics[i, ]
+ if (!all(c(row$IntervalLowCol, row$IntervalHighCol) %in% names(fit_df))) {
+ return(NULL)
+ }
+ ci_low <- fit_df[[row$IntervalLowCol]]
+ ci_high <- fit_df[[row$IntervalHighCol]]
+ if (all(is.na(ci_low)) || all(is.na(ci_high))) {
+ return(NULL)
+ }
+ data.frame(
+ MODEL_BASE = fit_df$MODEL_BASE,
+ PLOT_ID = fit_df$PLOT_ID,
+ VARIANT = fit_df$VARIANT,
+ Metric = row$Metric,
+ CI_low = ci_low,
+ CI_high = ci_high,
+ stringsAsFactors = FALSE
+ )
+ })
+
+ rows <- Filter(Negate(is.null), rows)
+ if (length(rows) == 0L) {
+ return(NULL)
+ }
+
+ do.call(rbind, rows)
+}
+
+plot_model_fit_floor_nice <- function(x, step) {
+ if (!is.finite(x) || !is.finite(step) || step <= 0) {
+ return(x)
+ }
+ round(step * floor((x + 1e-9) / step), 8)
+}
+
+plot_model_fit_ceiling_nice <- function(x, step) {
+ if (!is.finite(x) || !is.finite(step) || step <= 0) {
+ return(x)
+ }
+ round(step * ceiling((x - 1e-9) / step), 8)
+}
+
+plot_model_fit_single_axis_step <- function(metric) {
+ 0.05
+}
+
+plot_model_fit_display_axis_padding <- function(axis_min, axis_max, step) {
+ if (!is.finite(axis_min) || !is.finite(axis_max) || !is.finite(step) || step <= 0) {
+ return(0)
+ }
+
+ span <- axis_max - axis_min
+ if (!is.finite(span) || span <= 0) {
+ return(0)
+ }
+
+ max(span * 0.035, step * 0.10)
+}
+
+plot_model_fit_round_midpoint <- function(x) {
+ if (!is.finite(x)) {
+ return(x)
+ }
+ round(x, 2)
+}
+
+plot_model_fit_single_tick_near_threshold <- function(axis_min, axis_max, auto_breaks, cutoff_breaks) {
+ candidate_diffs <- diff(sort(unique(c(axis_min, auto_breaks, axis_max))))
+ candidate_diffs <- candidate_diffs[is.finite(candidate_diffs) & candidate_diffs > 0]
+ ref_gap <- if (length(candidate_diffs) > 0L) stats::median(candidate_diffs) else (axis_max - axis_min) / 4
+ min(ref_gap * 0.45, (axis_max - axis_min) * 0.12)
+}
+
+plot_model_fit_auto_breaks <- function(metric, axis_min, axis_max) {
+ metric <- as.character(metric)[1]
+ axis_min <- suppressWarnings(min(axis_min, na.rm = TRUE))
+ axis_max <- suppressWarnings(max(axis_max, na.rm = TRUE))
+
+ if (!is.finite(axis_min) || !is.finite(axis_max) || axis_max <= axis_min) {
+ return(numeric())
+ }
+
+ span <- axis_max - axis_min
+ pretty_n <- if (metric %in% c("CFI", "TLI") && span > 0.22) 3 else 4
+ breaks <- pretty(c(axis_min, axis_max), n = pretty_n)
+ breaks <- breaks[is.finite(breaks)]
+ breaks <- breaks[breaks >= axis_min - 1e-9 & breaks <= axis_max + 1e-9]
+ unique(round(breaks, 10))
+}
+
+plot_model_fit_single_tick_spec_for_metric <- function(metric, axis_min, axis_max, cutoff_breaks) {
+ canonical_row <- plot_model_fit_metric_spec(metric)
+ canonical_min <- canonical_row$AxisMin
+ canonical_max <- canonical_row$AxisMax
+ expanded_high <- is.finite(axis_max) && axis_max > canonical_max + 1e-9
+
+ auto_breaks <- plot_model_fit_auto_breaks(metric, axis_min, axis_max)
+ auto_breaks <- auto_breaks[is.finite(auto_breaks)]
+ auto_breaks <- auto_breaks[auto_breaks >= axis_min - 1e-9 & auto_breaks <= axis_max + 1e-9]
+ auto_breaks <- auto_breaks[!(abs(auto_breaks - axis_min) < 1e-9 | abs(auto_breaks - axis_max) < 1e-9)]
+
+ near_threshold <- plot_model_fit_single_tick_near_threshold(axis_min, axis_max, auto_breaks, cutoff_breaks)
+ between_cutoffs <- vapply(auto_breaks, function(x) {
+ any(x > cutoff_breaks[-length(cutoff_breaks)] & x < cutoff_breaks[-1])
+ }, logical(1))
+ near_cutoff <- vapply(auto_breaks, function(x) {
+ any(abs(x - cutoff_breaks) <= near_threshold)
+ }, logical(1))
+
+ kept_breaks <- auto_breaks[!(between_cutoffs | near_cutoff)]
+ left_interval_breaks <- kept_breaks[kept_breaks > axis_min & kept_breaks < min(cutoff_breaks)]
+ allow_left_midpoint <- !(metric %in% c("RMSEA", "SRMR") && expanded_high)
+ if (allow_left_midpoint && length(left_interval_breaks) == 0L && axis_min < min(cutoff_breaks)) {
+ midpoint <- plot_model_fit_round_midpoint(mean(c(axis_min, min(cutoff_breaks))))
+ if (midpoint > axis_min + 1e-9 && midpoint < min(cutoff_breaks) - 1e-9) {
+ kept_breaks <- c(kept_breaks, midpoint)
+ }
+ }
+
+ if (identical(metric, "RMSEA") && axis_min <= 0.10 && axis_max >= 0.10) {
+ kept_breaks <- c(kept_breaks, 0.10)
+ }
+
+ force_axis_min_tick <- TRUE
+ force_axis_max_tick <- !expanded_high
+
+ tick_values <- c(kept_breaks, cutoff_breaks)
+ if (force_axis_min_tick) {
+ tick_values <- c(tick_values, axis_min)
+ }
+ if (force_axis_max_tick) {
+ tick_values <- c(tick_values, axis_max)
+ }
+
+ sort(unique(tick_values))
+}
+
+plot_model_fit_single_axis_spec <- function(metric_spec, value_df, interval_df = NULL, upper_expand = c("nice", "data")) {
+ upper_expand <- match.arg(upper_expand)
+ out <- metric_spec
+ out$DisplayMin <- out$AxisMin
+ out$DisplayMax <- out$AxisMax
+ interval_split <- NULL
+ if (!is.null(interval_df) && nrow(interval_df) > 0L) {
+ interval_split <- split(interval_df, as.character(interval_df$Metric))
+ }
+
+ for (i in seq_len(nrow(out))) {
+ metric <- out$Metric[i]
+ axis_min <- out$AxisMin[i]
+ axis_max <- out$AxisMax[i]
+ step <- plot_model_fit_single_axis_step(metric)
+ observed <- value_df$Value[value_df$Metric == metric]
+ observed <- observed[is.finite(observed)]
+
+ if (!is.null(interval_split) && metric %in% names(interval_split)) {
+ metric_interval <- interval_split[[metric]]
+ observed <- c(observed, metric_interval$CI_low, metric_interval$CI_high)
+ }
+
+ observed <- observed[is.finite(observed)]
+ if (length(observed) == 0L) {
+ next
+ }
+
+ lower_bound <- min(axis_min, observed)
+ upper_bound <- max(axis_max, observed)
+ expanded_high <- upper_bound > axis_max + 1e-9
+ out$AxisMin[i] <- plot_model_fit_floor_nice(lower_bound, step)
+ out$AxisMax[i] <- if (identical(upper_expand, "nice")) {
+ plot_model_fit_ceiling_nice(upper_bound, step)
+ } else {
+ round(upper_bound, 3)
+ }
+ out$DisplayMin[i] <- out$AxisMin[i]
+ out$DisplayMax[i] <- if (identical(upper_expand, "data") && expanded_high) {
+ round(out$AxisMax[i] + plot_model_fit_display_axis_padding(out$AxisMin[i], out$AxisMax[i], step), 3)
+ } else {
+ out$AxisMax[i]
+ }
+ }
+
+ out
+}
+
+plot_model_fit_single_band_spec <- function(metrics, axis_spec = NULL, display = FALSE) {
+ if (is.null(axis_spec)) {
+ axis_spec <- plot_model_fit_metric_spec(metrics)
+ }
+ rows <- list()
+ for (metric in metrics) {
+ axis_row <- axis_spec[match(metric, axis_spec$Metric), , drop = FALSE]
+ axis_min <- if (isTRUE(display) && "DisplayMin" %in% names(axis_row)) axis_row$DisplayMin else axis_row$AxisMin
+ axis_max <- if (isTRUE(display) && "DisplayMax" %in% names(axis_row)) axis_row$DisplayMax else axis_row$AxisMax
+ if (metric %in% c("CFI", "TLI")) {
+ rows[[length(rows) + 1L]] <- data.frame(
+ Metric = metric,
+ xmin = c(axis_min, 0.90, 0.95),
+ xmax = c(0.90, 0.95, axis_max),
+ band = c("Needs work", "Acceptable", "Good"),
+ stringsAsFactors = FALSE
+ )
+ } else if (metric == "RMSEA") {
+ rows[[length(rows) + 1L]] <- data.frame(
+ Metric = metric,
+ xmin = c(0.00, 0.05, 0.08, 0.10),
+ xmax = c(0.05, 0.08, 0.10, axis_max),
+ band = c("Good", "Acceptable", "Near limit", "Needs work"),
+ stringsAsFactors = FALSE
+ )
+ } else if (metric == "SRMR") {
+ rows[[length(rows) + 1L]] <- data.frame(
+ Metric = metric,
+ xmin = c(0.00, 0.06, 0.08),
+ xmax = c(0.06, 0.08, axis_max),
+ band = c("Good", "Almost good", "Needs work"),
+ stringsAsFactors = FALSE
+ )
+ }
+ }
+ out <- do.call(rbind, rows)
+ out$Metric <- factor(out$Metric, levels = metrics)
+ out
+}
+
+plot_model_fit_cutoff_spec <- function(metrics, style = c("single", "grouped")) {
+ style <- match.arg(style)
+ spec <- plot_model_fit_metric_spec(metrics)
+ rows <- lapply(seq_len(nrow(spec)), function(i) {
+ row <- spec[i, ]
+ cutoffs <- if (style == "grouped") {
+ row$Primary
+ } else if (row$Metric %in% c("CFI", "TLI")) {
+ c(row$Good, row$Ideal)
+ } else if (row$Metric == "RMSEA") {
+ c(row$Ideal, row$Good)
+ } else {
+ c(row$Ideal, row$Good)
+ }
+
+ data.frame(
+ Metric = row$Metric,
+ cutoff = cutoffs,
+ stringsAsFactors = FALSE
+ )
+ })
+ out <- do.call(rbind, rows)
+ out$Metric <- factor(out$Metric, levels = metrics)
+ out
+}
+
+plot_model_fit_tick_spec <- function(metrics, axis_spec = NULL) {
+ if (is.null(axis_spec)) {
+ axis_spec <- plot_model_fit_metric_spec(metrics)
+ }
+ cutoff_df <- plot_model_fit_cutoff_spec(metrics, style = "single")
+ rows <- list()
+ for (metric in metrics) {
+ axis_row <- axis_spec[match(metric, axis_spec$Metric), , drop = FALSE]
+ axis_min <- axis_row$AxisMin
+ axis_max <- axis_row$AxisMax
+ cutoff_breaks <- cutoff_df$cutoff[cutoff_df$Metric == metric]
+ ticks <- plot_model_fit_single_tick_spec_for_metric(metric, axis_min, axis_max, cutoff_breaks)
+
+ rows[[length(rows) + 1L]] <- data.frame(
+ Metric = metric,
+ x = ticks,
+ label = sprintf("%.2f", ticks),
+ stringsAsFactors = FALSE
+ )
+ }
+ out <- do.call(rbind, rows)
+ out$Metric <- factor(out$Metric, levels = metrics)
+ out$is_cutoff <- mapply(function(metric, x) {
+ x %in% cutoff_df$cutoff[cutoff_df$Metric == metric]
+ }, as.character(out$Metric), out$x)
+ out
+}
+
+plot_model_fit_assign_band <- function(metric, value, band_df) {
+ if (is.na(value)) {
+ return(NA_character_)
+ }
+ segments <- band_df[band_df$Metric == metric, , drop = FALSE]
+ hit <- which(value >= segments$xmin & value <= segments$xmax)
+ if (length(hit) == 0L) {
+ hit <- if (value < min(segments$xmin)) 1L else nrow(segments)
+ } else if (length(hit) > 1L) {
+ direction <- plot_model_fit_metric_spec(metric)$Direction[1]
+ hit <- if (identical(direction, "higher")) max(hit) else min(hit)
+ }
+ segments$band[hit[1]]
+}
+
+plot_model_fit_rescale <- function(values, to = c(0, 1), from = range(values, na.rm = TRUE)) {
+ if (diff(from) == 0) {
+ return(rep(mean(to), length(values)))
+ }
+ (values - from[1]) / diff(from) * diff(to) + to[1]
+}
+
+plot_model_fit_compute_band_score <- function(value, direction, poor, good, ideal) {
+ if (is.na(value)) {
+ return(NA_real_)
+ }
+ if (direction == "higher") {
+ if (value < good) {
+ score <- -1 + (value - poor) / (good - poor)
+ return(max(min(score, -0.05), -1))
+ }
+ if (value < ideal) {
+ score <- 0.25 + 0.50 * (value - good) / (ideal - good)
+ return(min(max(score, 0.25), 0.75))
+ }
+ score <- 0.75 + 0.25 * (value - ideal) / (1 - ideal)
+ return(min(max(score, 0.75), 1))
+ }
+
+ if (value > good) {
+ score <- -1 + (poor - value) / (poor - good)
+ return(max(min(score, -0.05), -1))
+ }
+ if (value > ideal) {
+ score <- 0.25 + 0.50 * (good - value) / (good - ideal)
+ return(min(max(score, 0.25), 0.75))
+ }
+ score <- 0.75 + 0.25 * (ideal - value) / ideal
+ min(max(score, 0.75), 1)
+}
+
+plot_model_fit_choose_incremental_ymin <- function(values) {
+ values <- values[is.finite(values)]
+ if (length(values) == 0L) {
+ return(0.80)
+ }
+
+ min_value <- min(values)
+ candidates <- seq(0.80, 0.00, by = -0.05)
+ candidates <- candidates[candidates <= min_value + 1e-9]
+ if (length(candidates) == 0L) {
+ return(0.00)
+ }
+
+ visible_fraction <- (min_value - candidates) / (1 - candidates)
+ keep <- candidates[visible_fraction >= 0.08]
+ if (length(keep) > 0L) {
+ return(max(keep))
+ }
+
+ min(candidates)
+}
+
+plot_model_fit_choose_incremental_ymax <- function(values) {
+ values <- values[is.finite(values)]
+ if (length(values) == 0L) {
+ return(1.00)
+ }
+
+ max(1.00, plot_model_fit_ceiling_nice(max(values), 0.05))
+}
+
+plot_model_fit_choose_error_ymax <- function(values, ci_high = NULL) {
+ observed <- c(values, ci_high)
+ observed <- observed[is.finite(observed)]
+ required_max <- if (length(observed) > 0L) {
+ max(c(0.08, observed))
+ } else {
+ 0.08
+ }
+
+ candidates <- c(0.08, 0.10, 0.12, 0.15, 0.20, 0.25)
+ keep <- candidates[candidates >= required_max - 1e-9]
+ if (length(keep) > 0L) {
+ return(min(keep))
+ }
+
+ max(0.08, plot_model_fit_ceiling_nice(required_max, 0.05))
+}
+
+plot_model_fit_build_model_spec <- function(model_names) {
+ n_models <- length(model_names)
+ offsets <- if (n_models == 1L) 0 else seq(-0.24, 0.24, length.out = n_models)
+ data.frame(
+ MODEL_BASE = model_names,
+ Fill = plot_model_fit_model_palette(n_models),
+ Offset = offsets,
+ stringsAsFactors = FALSE
+ )
+}
+
+
+
+
+plot_model_fit_group_bar_layout <- function(n_groups) {
+ if (!is.numeric(n_groups) || length(n_groups) != 1L || is.na(n_groups) || n_groups <= 1L) {
+ return(list(offsets = 0, half_width = 0.09))
+ }
+
+ center_span <- if (n_groups == 2L) {
+ 0.24
+ } else if (n_groups == 3L) {
+ 0.36
+ } else if (n_groups == 4L) {
+ 0.46
+ } else {
+ min(0.58, 0.12 * (n_groups - 1L))
+ }
+
+ offsets <- seq(-center_span / 2, center_span / 2, length.out = n_groups)
+ width <- min(0.18, max(0.11, (center_span / (n_groups - 1L)) * 0.72))
+
+ list(
+ offsets = offsets,
+ half_width = width / 2
+ )
+}
+
+plot_model_fit_bar_expand <- function(n_metrics) {
+ if (!is.numeric(n_metrics) || length(n_metrics) != 1L || is.na(n_metrics) || n_metrics <= 2L) {
+ return(ggplot2::expansion(mult = c(0.025, 0.015)))
+ }
+ if (n_metrics == 3L) {
+ return(ggplot2::expansion(mult = c(0.04, 0.025)))
+ }
+ ggplot2::expansion(mult = c(0.05, 0.03))
+}
+
+plot_model_fit_group_bar_breaks <- function(limits) {
+ axis_min <- suppressWarnings(min(limits, na.rm = TRUE))
+ axis_max <- suppressWarnings(max(limits, na.rm = TRUE))
+ if (!is.finite(axis_min) || !is.finite(axis_max) || axis_max <= axis_min) {
+ return(numeric())
+ }
+
+ if (axis_max > 0.30) {
+ return(round(seq(axis_min, min(1.00, axis_max), by = 0.05), 2))
+ }
+
+ step <- if (axis_max <= 0.10 + 1e-9) 0.02 else 0.05
+ base_breaks <- seq(axis_min, axis_max, by = step)
+ threshold_breaks <- c(0.05, 0.08)
+ threshold_breaks <- threshold_breaks[threshold_breaks >= axis_min - 1e-9 & threshold_breaks <= axis_max + 1e-9]
+ unique(round(sort(c(base_breaks, threshold_breaks, axis_max)), 2))
+}
+
+plot_model_fit_group_bar_limits <- function(limits) {
+ axis_min <- suppressWarnings(min(limits, na.rm = TRUE))
+ axis_max <- suppressWarnings(max(limits, na.rm = TRUE))
+ if (!is.finite(axis_min) || !is.finite(axis_max) || axis_max <= axis_min) {
+ return(limits)
+ }
+
+ if (axis_max > 0.30) {
+ lower <- min(0.80, plot_model_fit_ceiling_nice(axis_min, 0.05))
+ upper <- plot_model_fit_choose_incremental_ymax(axis_max)
+ return(c(lower, upper))
+ }
+
+ if (axis_max <= 0.085) {
+ return(c(0.00, 0.08))
+ }
+
+ c(0.00, plot_model_fit_choose_error_ymax(axis_max))
+}
+
+plot_model_fit_group_bar_labels <- function(x) {
+ formatC(x, format = "f", digits = 2)
+}
+
+plot_model_fit_bar_label_y <- function(anchor, ymin, ymax, threshold, min_offset, proximity = 0.02, threshold_bonus = 0.0012) {
+ panel_span <- ymax - ymin
+ if (!is.finite(anchor) || !is.finite(panel_span) || panel_span <= 0) {
+ return(anchor)
+ }
+
+ base_offset <- max(min_offset, panel_span * 0.004)
+ candidate_y <- anchor + base_offset
+ near_threshold <- is.finite(threshold) && abs(candidate_y - threshold) <= panel_span * proximity
+ total_offset <- base_offset + if (near_threshold) panel_span * threshold_bonus else 0
+ anchor + total_offset
+}
+
+plot_model_fit_bar_marker_placement <- function(value, ymin, ymax, min_visible_fraction = 0.08) {
+ panel_span <- ymax - ymin
+ visible_height <- value - ymin
+ if (!is.finite(value) || !is.finite(visible_height) || !is.finite(panel_span) || panel_span <= 0 || visible_height <= 0) {
+ return("above")
+ }
+
+ if (visible_height / panel_span >= min_visible_fraction) {
+ return("inside")
+ }
+
+ "above"
+}
+
+plot_model_fit_bar_marker_y <- function(value, label_y, ymin, ymax, shape_code = NA_integer_, placement = c("inside", "above")) {
+ placement <- match.arg(placement)
+ panel_span <- ymax - ymin
+ visible_height <- value - ymin
+ if (!is.finite(value) || !is.finite(visible_height) || !is.finite(panel_span) || panel_span <= 0 || visible_height <= 0) {
+ return(value)
+ }
+
+ if (identical(placement, "inside")) {
+ return(value)
+ }
+
+ tall_shape <- is.finite(shape_code) && shape_code %in% c(17, 24, 25)
+ rise_fraction <- 0.018 + if (tall_shape) 0.004 else 0
+ value + panel_span * rise_fraction
+}
+
+
+
+
+
+
+
+
+
diff --git a/R/plot_model_fit-methods.R b/R/plot_model_fit-methods.R
new file mode 100644
index 0000000..8e57fdd
--- /dev/null
+++ b/R/plot_model_fit-methods.R
@@ -0,0 +1,854 @@
+plot_model_fit_dispatch <- function(x, type = "default", metrics = NULL, test_mode = "all", verbose = TRUE) {
+ input_class <- plot_model_fit_validate_input(x)
+ resolved_metrics <- plot_model_fit_resolve_metrics(x, metrics = metrics, verbose = verbose)
+ resolved_test_mode <- plot_model_fit_resolve_test_mode(test_mode)
+ fit_df <- plot_model_fit_prepare_data(x, resolved_metrics, input_class, resolved_test_mode)
+ resolved_type <- plot_model_fit_resolve_type(type, input_class, nrow(fit_df))
+ metric_spec <- plot_model_fit_metric_spec(resolved_metrics)
+
+ if (identical(resolved_type, "bullet")) {
+ return(plot_model_fit_single_bullet(fit_df, metric_spec))
+ }
+ if (identical(resolved_type, "dots")) {
+ return(plot_model_fit_threshold_dots(fit_df, metric_spec))
+ }
+ if (identical(resolved_type, "bars")) {
+ return(plot_model_fit_grouped_threshold_bars(fit_df, metric_spec))
+ }
+ plot_model_fit_heatmap_scorecard(fit_df, metric_spec)
+}
+
+#' @export
+plot_model_fit.model_fit <- function(x, type = "default", metrics = NULL, test_mode = "all", verbose = TRUE, ...) {
+ plot_model_fit_dispatch(x, type = type, metrics = metrics, test_mode = test_mode, verbose = verbose)
+}
+
+#' @export
+plot_model_fit.compare_model_fit <- function(x, type = "default", metrics = NULL, test_mode = "all", verbose = TRUE, ...) {
+ plot_model_fit_dispatch(x, type = type, metrics = metrics, test_mode = test_mode, verbose = verbose)
+}
+
+plot_model_fit_single_bullet <- function(fit_df, metric_spec) {
+ if (nrow(fit_df) != 1L) {
+ cli::cli_abort(c(
+ "`type = 'bullet'` requires a single-row fit summary after applying `test_mode`.",
+ "Use `type = 'dots'` to visualize multiple tests or test variants."
+ ))
+ }
+
+ metrics <- metric_spec$Metric
+ size_spec <- plot_model_fit_size_spec("bullet", n_metrics = length(metrics), n_rows = 1L)
+ interval_df <- plot_model_fit_extract_interval_df(fit_df, metric_spec)
+
+ value_df <- data.frame(
+ Metric = factor(metrics, levels = metrics),
+ Value = as.numeric(fit_df[1, metrics, drop = TRUE]),
+ AxisMin = metric_spec$AxisMin,
+ AxisMax = metric_spec$AxisMax,
+ stringsAsFactors = FALSE
+ )
+ value_df$ValueLabel <- ifelse(is.na(value_df$Value), "", sprintf("%.3f", value_df$Value))
+
+ if (!is.null(interval_df) && nrow(interval_df) > 0L) {
+ idx <- match(interval_df$Metric, value_df$Metric)
+ value_df$ValueLabel[idx] <- ifelse(
+ is.na(value_df$Value[idx]),
+ "",
+ sprintf("%.3f [%.3f, %.3f]", value_df$Value[idx], interval_df$CI_low, interval_df$CI_high)
+ )
+ }
+
+ metric_spec <- plot_model_fit_single_axis_spec(metric_spec, value_df, interval_df, upper_expand = "data")
+ band_spec <- plot_model_fit_single_band_spec(metrics, axis_spec = metric_spec, display = TRUE)
+ cutoff_spec <- plot_model_fit_cutoff_spec(metrics, style = "single")
+ tick_spec <- plot_model_fit_tick_spec(metrics, axis_spec = metric_spec)
+ value_df$AxisMin <- metric_spec$AxisMin[match(as.character(value_df$Metric), metric_spec$Metric)]
+ value_df$AxisMax <- metric_spec$AxisMax[match(as.character(value_df$Metric), metric_spec$Metric)]
+ value_df$Status <- vapply(
+ seq_len(nrow(value_df)),
+ function(i) plot_model_fit_assign_band(as.character(value_df$Metric[i]), value_df$Value[i], band_spec),
+ character(1)
+ )
+
+ layout <- list(
+ point_y = 1.00,
+ band_ymin = 0.80,
+ band_ymax = 1.20,
+ tick_y = size_spec$tick_y,
+ proximity_threshold = 0.035,
+ callout_x_offset = 0.05
+ )
+
+ value_df <- plot_model_fit_single_callout_layout(value_df, cutoff_spec, layout)
+ valid_df <- value_df[is.finite(value_df$Value), , drop = FALSE]
+ plain_df <- valid_df[!valid_df$use_callout, , drop = FALSE]
+ callout_df <- valid_df[valid_df$use_callout, , drop = FALSE]
+ callout_df$PointY <- rep(layout$point_y, nrow(callout_df))
+
+ axis_df <- data.frame(
+ Metric = factor(metrics, levels = metrics),
+ x = metric_spec$DisplayMin,
+ y = layout$tick_y,
+ stringsAsFactors = FALSE
+ )
+ axis_df2 <- data.frame(
+ Metric = factor(metrics, levels = metrics),
+ x = metric_spec$DisplayMax,
+ y = layout$tick_y,
+ stringsAsFactors = FALSE
+ )
+
+ band_fill <- c(
+ "Good" = "#9fd39a",
+ "Almost good" = "#c9d97a",
+ "Acceptable" = "#dfc55b",
+ "Near limit" = "#d6d6d6",
+ "Needs work" = "#bebebe"
+ )
+ status_fill <- c(
+ "Good" = "#137f5b",
+ "Almost good" = "#6d9d29",
+ "Acceptable" = "#b77f00",
+ "Near limit" = "#8b8b8b",
+ "Needs work" = "#7e7e7e"
+ )
+
+ p <- ggplot2::ggplot() +
+ ggplot2::geom_rect(
+ data = band_spec,
+ ggplot2::aes(xmin = .data$xmin, xmax = .data$xmax, ymin = layout$band_ymin, ymax = layout$band_ymax, fill = .data$band),
+ color = NA
+ ) +
+ ggplot2::geom_segment(
+ data = cutoff_spec,
+ ggplot2::aes(x = .data$cutoff, xend = .data$cutoff, y = layout$tick_y + 0.03, yend = layout$band_ymax),
+ color = "#676767",
+ linewidth = 0.8
+ )
+
+ if (!is.null(interval_df) && nrow(interval_df) > 0L) {
+ p <- p + ggplot2::geom_segment(
+ data = interval_df,
+ ggplot2::aes(x = .data$CI_low, xend = .data$CI_high, y = layout$point_y, yend = layout$point_y),
+ linewidth = 3,
+ color = "#2f2f2f"
+ )
+ }
+
+ p <- p +
+ ggplot2::geom_point(
+ data = valid_df,
+ ggplot2::aes(x = .data$Value, y = layout$point_y, fill = .data$Status),
+ size = 6.6,
+ shape = 21,
+ color = "white",
+ stroke = 1.2
+ ) +
+ plot_model_fit_geom_plain_label(
+ data = plain_df,
+ ggplot2::aes(x = .data$Value, y = layout$point_y, label = .data$ValueLabel),
+ inherit.aes = FALSE,
+ size = plot_model_fit_pt(size_spec$value_pt),
+ point_size = 6.6,
+ gap_mm = 1.15,
+ text_colour = "#1f1f1f",
+ show.legend = FALSE
+ ) +
+ plot_model_fit_geom_dot_callout(
+ data = callout_df,
+ ggplot2::aes(x = .data$Value, y = .data$PointY, label = .data$ValueLabel, hjust = .data$label_hjust),
+ inherit.aes = FALSE,
+ colour = "#505050",
+ text_colour = "#1f1f1f",
+ size = plot_model_fit_pt(size_spec$value_pt),
+ point_size = 6.6,
+ label_dx_mm = size_spec$callout_label_dx_mm,
+ label_dy_mm = size_spec$callout_label_dy_mm,
+ anchor_rise_mm = size_spec$callout_anchor_rise_mm,
+ arrow_mm = size_spec$callout_arrow_mm,
+ linewidth = size_spec$callout_curve_linewidth,
+ show.legend = FALSE
+ ) +
+ ggplot2::geom_text(
+ data = tick_spec[!tick_spec$is_cutoff, , drop = FALSE],
+ ggplot2::aes(x = .data$x, y = layout$tick_y, label = .data$label),
+ color = "#5e5e5e",
+ size = plot_model_fit_pt(size_spec$tick_pt)
+ ) +
+ ggplot2::geom_text(
+ data = tick_spec[tick_spec$is_cutoff, , drop = FALSE],
+ ggplot2::aes(x = .data$x, y = layout$tick_y, label = .data$label),
+ color = "#4a4a4a",
+ size = plot_model_fit_pt(size_spec$cutoff_pt),
+ fontface = "bold"
+ ) +
+ ggplot2::geom_blank(data = axis_df, ggplot2::aes(x = .data$x, y = .data$y)) +
+ ggplot2::geom_blank(data = axis_df2, ggplot2::aes(x = .data$x, y = .data$y)) +
+ ggplot2::facet_wrap(~Metric, ncol = 1, scales = "free_x", strip.position = "left") +
+ ggplot2::scale_fill_manual(values = c(band_fill, status_fill), guide = "none") +
+ ggplot2::scale_x_continuous(expand = ggplot2::expansion(mult = c(0, 0))) +
+ ggplot2::coord_cartesian(clip = "off") +
+ ggplot2::labs(title = "Model fit indices", subtitle = "Single-fit bullet chart", x = NULL, y = NULL) +
+ ggplot2::theme_minimal(base_size = size_spec$base) +
+ ggplot2::theme(
+ panel.grid = ggplot2::element_blank(),
+ axis.text.y = ggplot2::element_blank(),
+ axis.text.x = ggplot2::element_blank(),
+ axis.ticks.x = ggplot2::element_blank(),
+ axis.title = ggplot2::element_blank(),
+ plot.title.position = "plot",
+ strip.placement = "outside",
+ strip.background = ggplot2::element_blank(),
+ strip.text = ggplot2::element_text(face = "bold", size = size_spec$strip),
+ plot.title = ggplot2::element_text(size = size_spec$title, face = "bold"),
+ plot.subtitle = ggplot2::element_text(size = size_spec$subtitle),
+ plot.margin = ggplot2::margin(18, 24, 14, 18)
+ )
+
+ p
+}
+
+plot_model_fit_single_callout_layout <- function(value_df, cutoff_df, layout) {
+ out <- value_df
+ range_width <- out$AxisMax - out$AxisMin
+ right_x <- pmin(out$Value + range_width * layout$callout_x_offset, out$AxisMax - range_width * 0.018)
+ left_x <- pmax(out$Value - range_width * layout$callout_x_offset, out$AxisMin + range_width * 0.018)
+ default_side <- ifelse(out$Value > out$AxisMin + range_width * 0.72, "left", "right")
+
+ nearest_distance <- function(metric_name, candidate_x) {
+ cutoffs <- cutoff_df$cutoff[cutoff_df$Metric == metric_name]
+ if (length(cutoffs) == 0L) {
+ return(Inf)
+ }
+ min(abs(candidate_x - cutoffs))
+ }
+
+ right_near <- mapply(nearest_distance, as.character(out$Metric), right_x) <= range_width * layout$proximity_threshold
+ left_near <- mapply(nearest_distance, as.character(out$Metric), left_x) <= range_width * layout$proximity_threshold
+ label_side <- ifelse(
+ default_side == "right" & right_near,
+ "left",
+ ifelse(default_side == "left" & left_near & !right_near, "right", default_side)
+ )
+
+ point_near_cutoff <- mapply(function(metric_name, x, width) {
+ cutoffs <- cutoff_df$cutoff[cutoff_df$Metric == metric_name]
+ if (length(cutoffs) == 0L || !is.finite(x) || !is.finite(width)) {
+ return(FALSE)
+ }
+ min(abs(x - cutoffs)) <= width * layout$proximity_threshold
+ }, as.character(out$Metric), out$Value, range_width)
+
+ out$use_callout <- is.finite(out$Value) & point_near_cutoff
+ out$label_hjust <- ifelse(label_side == "right", 0, 1)
+ out
+}
+
+plot_model_fit_threshold_dots <- function(fit_df, metric_spec) {
+ metrics <- metric_spec$Metric
+ model_levels <- unique(fit_df$MODEL_BASE)
+ plot_levels <- unique(fit_df$PLOT_ID)
+ size_spec <- plot_model_fit_size_spec("dots", n_metrics = length(metrics), n_rows = length(plot_levels))
+ row_y_values <- rev(seq_along(plot_levels))
+ names(row_y_values) <- plot_levels
+ show_variant_shape <- any(duplicated(fit_df$MODEL_BASE))
+
+ long_df <- do.call(rbind, lapply(seq_len(nrow(metric_spec)), function(i) {
+ row <- metric_spec[i, ]
+ data.frame(
+ MODEL_BASE = fit_df$MODEL_BASE,
+ PLOT_ID = fit_df$PLOT_ID,
+ VARIANT = fit_df$VARIANT,
+ Metric = row$Metric,
+ Value = fit_df[[row$Metric]],
+ AxisMin = row$AxisMin,
+ AxisMax = row$AxisMax,
+ stringsAsFactors = FALSE
+ )
+ }))
+ long_df$Metric <- factor(long_df$Metric, levels = metrics)
+ long_df$MODEL_y <- unname(row_y_values[long_df$PLOT_ID])
+ long_df$ValueLabel <- ifelse(is.na(long_df$Value), "", sprintf("%.3f", long_df$Value))
+
+ interval_df <- plot_model_fit_extract_interval_df(fit_df, metric_spec)
+ if (!is.null(interval_df) && nrow(interval_df) > 0L) {
+ interval_df$MODEL_y <- unname(row_y_values[interval_df$PLOT_ID])
+ interval_df$Metric <- factor(interval_df$Metric, levels = metrics)
+ }
+
+ metric_spec <- plot_model_fit_single_axis_spec(metric_spec, long_df, interval_df, upper_expand = "data")
+ long_df$AxisMin <- metric_spec$AxisMin[match(as.character(long_df$Metric), metric_spec$Metric)]
+ long_df$AxisMax <- metric_spec$AxisMax[match(as.character(long_df$Metric), metric_spec$Metric)]
+ if (!is.null(interval_df) && nrow(interval_df) > 0L) {
+ interval_df$AxisMin <- metric_spec$AxisMin[match(as.character(interval_df$Metric), metric_spec$Metric)]
+ interval_df$AxisMax <- metric_spec$AxisMax[match(as.character(interval_df$Metric), metric_spec$Metric)]
+ }
+
+ band_spec <- plot_model_fit_single_band_spec(metrics, axis_spec = metric_spec)
+ active_band_spec <- band_spec[band_spec$band != "Needs work", , drop = FALSE]
+ cutoff_spec <- plot_model_fit_cutoff_spec(metrics, style = "single")
+ tick_spec <- plot_model_fit_tick_spec(metrics, axis_spec = metric_spec)
+
+ layout <- list(
+ data_ymin = size_spec$data_ymin,
+ data_ymax = length(plot_levels) + size_spec$data_ymax_pad,
+ tick_y = size_spec$tick_y,
+ y_limits = c(size_spec$y_lower, length(plot_levels) + size_spec$y_upper_pad),
+ proximity_threshold = 0.035
+ )
+
+ long_df <- plot_model_fit_multi_callout_layout(long_df, cutoff_spec, layout)
+ plain_df <- long_df[!long_df$use_callout & is.finite(long_df$Value), , drop = FALSE]
+ callout_df <- long_df[long_df$use_callout & is.finite(long_df$Value), , drop = FALSE]
+ point_df <- long_df[is.finite(long_df$Value), , drop = FALSE]
+
+ axis_min_df <- data.frame(Metric = factor(metrics, levels = metrics), x = metric_spec$AxisMin, y = layout$tick_y)
+ axis_max_df <- data.frame(Metric = factor(metrics, levels = metrics), x = metric_spec$AxisMax, y = layout$tick_y)
+
+ point_palette <- stats::setNames(plot_model_fit_model_palette(length(model_levels)), model_levels)
+ band_fill <- c(
+ "Good" = "#dff0dc",
+ "Almost good" = "#e7efbf",
+ "Acceptable" = "#f4e7a6",
+ "Near limit" = "#f3f3f3"
+ )
+ shape_values <- stats::setNames(plot_model_fit_variant_shapes(length(unique(point_df$VARIANT))), unique(point_df$VARIANT))
+
+ p <- ggplot2::ggplot() +
+ ggplot2::geom_rect(
+ data = active_band_spec,
+ ggplot2::aes(xmin = .data$xmin, xmax = .data$xmax, ymin = layout$data_ymin, ymax = layout$data_ymax, fill = .data$band),
+ inherit.aes = FALSE,
+ alpha = 0.95
+ ) +
+ ggplot2::geom_segment(
+ data = cutoff_spec,
+ ggplot2::aes(x = .data$cutoff, xend = .data$cutoff, y = layout$data_ymin, yend = layout$data_ymax),
+ inherit.aes = FALSE,
+ color = "#5f5f5f",
+ linewidth = 0.75,
+ linetype = "dashed"
+ )
+
+ if (!is.null(interval_df) && nrow(interval_df) > 0L) {
+ p <- p + ggplot2::geom_segment(
+ data = interval_df,
+ ggplot2::aes(x = .data$CI_low, xend = .data$CI_high, y = .data$MODEL_y, yend = .data$MODEL_y, color = .data$MODEL_BASE),
+ inherit.aes = FALSE,
+ linewidth = 1.1,
+ show.legend = FALSE
+ )
+ }
+
+ if (show_variant_shape) {
+ p <- p +
+ ggplot2::geom_point(
+ data = point_df,
+ ggplot2::aes(x = .data$Value, y = .data$MODEL_y, shape = .data$VARIANT),
+ inherit.aes = FALSE,
+ size = 5.1,
+ color = "white",
+ show.legend = FALSE
+ ) +
+ ggplot2::geom_point(
+ data = point_df,
+ ggplot2::aes(x = .data$Value, y = .data$MODEL_y, color = .data$MODEL_BASE, shape = .data$VARIANT),
+ inherit.aes = FALSE,
+ size = 3.8
+ )
+ } else {
+ p <- p +
+ ggplot2::geom_point(
+ data = point_df,
+ ggplot2::aes(x = .data$Value, y = .data$MODEL_y),
+ inherit.aes = FALSE,
+ size = 5.1,
+ color = "white",
+ show.legend = FALSE
+ ) +
+ ggplot2::geom_point(
+ data = point_df,
+ ggplot2::aes(x = .data$Value, y = .data$MODEL_y, color = .data$MODEL_BASE),
+ inherit.aes = FALSE,
+ size = 3.8
+ )
+ }
+
+ p <- p +
+ plot_model_fit_geom_plain_label(
+ data = plain_df,
+ ggplot2::aes(x = .data$Value, y = .data$MODEL_y, label = .data$ValueLabel, colour = .data$MODEL_BASE),
+ inherit.aes = FALSE,
+ size = plot_model_fit_pt(size_spec$value_pt),
+ point_size = 5.1,
+ text_colour = "#1f1f1f",
+ gap_mm = 0.75,
+ show.legend = FALSE
+ ) +
+ plot_model_fit_geom_dot_callout(
+ data = callout_df,
+ ggplot2::aes(x = .data$Value, y = .data$MODEL_y, label = .data$ValueLabel, hjust = .data$label_hjust, colour = .data$MODEL_BASE),
+ inherit.aes = FALSE,
+ size = plot_model_fit_pt(size_spec$value_pt),
+ point_size = 5.1,
+ text_colour = "#1f1f1f",
+ label_dx_mm = size_spec$callout_label_dx_mm,
+ label_dy_mm = size_spec$callout_label_dy_mm,
+ anchor_rise_mm = size_spec$callout_anchor_rise_mm,
+ arrow_mm = size_spec$callout_arrow_mm,
+ linewidth = size_spec$callout_curve_linewidth,
+ show.legend = FALSE
+ ) +
+ ggplot2::geom_text(
+ data = tick_spec[!tick_spec$is_cutoff, , drop = FALSE],
+ ggplot2::aes(x = .data$x, y = layout$tick_y, label = .data$label),
+ inherit.aes = FALSE,
+ color = "#5e5e5e",
+ size = plot_model_fit_pt(size_spec$tick_pt)
+ ) +
+ ggplot2::geom_text(
+ data = tick_spec[tick_spec$is_cutoff, , drop = FALSE],
+ ggplot2::aes(x = .data$x, y = layout$tick_y, label = .data$label),
+ inherit.aes = FALSE,
+ color = "#4a4a4a",
+ size = plot_model_fit_pt(size_spec$cutoff_pt),
+ fontface = "bold"
+ ) +
+ ggplot2::geom_blank(data = axis_min_df, ggplot2::aes(x = .data$x, y = .data$y), inherit.aes = FALSE) +
+ ggplot2::geom_blank(data = axis_max_df, ggplot2::aes(x = .data$x, y = .data$y), inherit.aes = FALSE) +
+ ggplot2::scale_color_manual(values = point_palette) +
+ ggplot2::scale_fill_manual(values = band_fill, guide = "none") +
+ ggplot2::scale_y_continuous(
+ breaks = row_y_values,
+ labels = names(row_y_values),
+ limits = layout$y_limits
+ ) +
+ ggplot2::facet_wrap(~Metric, scales = "free_x", ncol = min(2L, length(metrics))) +
+ ggplot2::scale_x_continuous(expand = ggplot2::expansion(mult = c(0, 0.035))) +
+ ggplot2::coord_cartesian(clip = "off") +
+ ggplot2::labs(
+ title = "Model fit comparison",
+ subtitle = "Threshold-aware dot plot",
+ x = NULL,
+ y = NULL,
+ color = "Model"
+ ) +
+ ggplot2::theme_minimal(base_size = size_spec$base) +
+ ggplot2::theme(
+ panel.grid.minor = ggplot2::element_blank(),
+ legend.position = "bottom",
+ legend.box = "vertical",
+ legend.spacing.y = grid::unit(1.2, "mm"),
+ legend.box.spacing = grid::unit(1.0, "mm"),
+ legend.margin = ggplot2::margin(0, 0, 0, 0),
+ plot.title.position = "plot",
+ strip.text = ggplot2::element_text(face = "bold", size = size_spec$strip),
+ plot.title = ggplot2::element_text(size = size_spec$title, face = "bold"),
+ plot.subtitle = ggplot2::element_text(size = size_spec$subtitle),
+ axis.text.y = ggplot2::element_text(size = size_spec$axis_y, color = "#4a4a4a"),
+ legend.text = ggplot2::element_text(size = size_spec$legend_pt),
+ legend.title = ggplot2::element_text(size = size_spec$legend_pt + 0.5),
+ axis.text.x = ggplot2::element_blank(),
+ axis.ticks.x = ggplot2::element_blank()
+ ) +
+ ggplot2::guides(
+ color = ggplot2::guide_legend(order = 1),
+ shape = "none"
+ )
+
+ if (show_variant_shape) {
+ p <- p + ggplot2::scale_shape_manual(values = shape_values)
+ }
+
+ p
+}
+
+plot_model_fit_multi_callout_layout <- function(df, cutoff_df, layout) {
+ out <- df
+ out$use_callout <- FALSE
+ out$label_hjust <- 0.5
+
+ for (i in seq_len(nrow(out))) {
+ if (!is.finite(out$Value[i])) {
+ next
+ }
+ metric_name <- as.character(out$Metric[i])
+ cutoffs <- cutoff_df$cutoff[cutoff_df$Metric == metric_name]
+ range_width <- out$AxisMax[i] - out$AxisMin[i]
+ nearest_idx <- which.min(abs(out$Value[i] - cutoffs))
+ nearest_cutoff <- cutoffs[nearest_idx]
+ near_cutoff <- abs(out$Value[i] - nearest_cutoff) <= range_width * layout$proximity_threshold
+
+ if (!near_cutoff) {
+ next
+ }
+
+ place_left <- out$Value[i] <= nearest_cutoff
+ out$use_callout[i] <- TRUE
+ out$label_hjust[i] <- if (place_left) 1 else 0
+ }
+
+ out
+}
+
+plot_model_fit_grouped_threshold_bars <- function(fit_df, metric_spec) {
+ metrics <- metric_spec$Metric
+ model_levels <- unique(fit_df$MODEL_BASE)
+ plot_levels <- unique(fit_df$PLOT_ID)
+ size_spec <- plot_model_fit_size_spec("bars", n_metrics = length(metrics), n_rows = length(plot_levels))
+ model_spec <- plot_model_fit_build_model_spec(model_levels)
+ group_layout <- plot_model_fit_group_bar_layout(length(plot_levels))
+ plot_spec <- data.frame(PLOT_ID = plot_levels, PlotOffset = group_layout$offsets, stringsAsFactors = FALSE)
+ show_variant_shape <- any(duplicated(fit_df$MODEL_BASE))
+ shape_values <- NULL
+ if (show_variant_shape) {
+ variant_levels <- unique(fit_df$VARIANT)
+ shape_values <- stats::setNames(plot_model_fit_variant_shapes(length(variant_levels)), variant_levels)
+ }
+
+ metric_panel <- metric_spec[, c("Metric", "Panel", "Primary", "Direction", "ShowInterval", "IntervalLowCol", "IntervalHighCol"), drop = FALSE]
+ metric_panel$metric_id <- stats::ave(seq_len(nrow(metric_panel)), metric_panel$Panel, FUN = seq_along)
+ metric_panel$ThresholdLabel <- ifelse(
+ metric_panel$Direction == "higher",
+ paste0(">= ", formatC(metric_panel$Primary, format = "f", digits = 2)),
+ paste0("<= ", formatC(metric_panel$Primary, format = "f", digits = 2))
+ )
+
+ bar_df <- do.call(rbind, lapply(seq_len(nrow(metric_panel)), function(i) {
+ row <- metric_panel[i, ]
+ data.frame(
+ MODEL_BASE = fit_df$MODEL_BASE,
+ PLOT_ID = fit_df$PLOT_ID,
+ VARIANT = fit_df$VARIANT,
+ Metric = row$Metric,
+ Panel = row$Panel,
+ Threshold = row$Primary,
+ ThresholdLabel = row$ThresholdLabel,
+ metric_id = row$metric_id,
+ ShowInterval = row$ShowInterval,
+ IntervalLowCol = row$IntervalLowCol,
+ IntervalHighCol = row$IntervalHighCol,
+ Value = fit_df[[row$Metric]],
+ stringsAsFactors = FALSE
+ )
+ }))
+ panel_levels <- c("Incremental fit (CFI & TLI)", "Approximation error (RMSEA & SRMR)")
+ bar_df$Panel <- factor(bar_df$Panel, levels = panel_levels)
+ bar_df$Metric <- factor(bar_df$Metric, levels = metrics)
+ bar_df <- merge(bar_df, model_spec, by = "MODEL_BASE", all.x = TRUE, sort = FALSE)
+ bar_df <- merge(bar_df, plot_spec, by = "PLOT_ID", all.x = TRUE, sort = FALSE)
+ bar_df$MODEL_BASE <- factor(bar_df$MODEL_BASE, levels = model_levels)
+ bar_df <- bar_df[order(bar_df$Panel, bar_df$metric_id, bar_df$PLOT_ID), ]
+ bar_df$x <- bar_df$metric_id + bar_df$PlotOffset
+ bar_df$xmin <- bar_df$x - group_layout$half_width
+ bar_df$xmax <- bar_df$x + group_layout$half_width
+ bar_df$ValueLabel <- ifelse(is.na(bar_df$Value), "", sprintf("%.3f", bar_df$Value))
+
+ interval_source_df <- plot_model_fit_extract_interval_df(fit_df, metric_spec)
+ panel_levels <- levels(bar_df$Panel)
+ incremental_ymin <- plot_model_fit_choose_incremental_ymin(bar_df$Value[bar_df$Panel == "Incremental fit (CFI & TLI)"])
+ incremental_ymax <- plot_model_fit_choose_incremental_ymax(bar_df$Value[bar_df$Panel == "Incremental fit (CFI & TLI)"])
+ approximation_ymax <- plot_model_fit_choose_error_ymax(
+ bar_df$Value[bar_df$Panel == "Approximation error (RMSEA & SRMR)"],
+ ci_high = if (!is.null(interval_source_df) && nrow(interval_source_df) > 0L) interval_source_df$CI_high else NULL
+ )
+ axis_df <- data.frame(
+ Panel = factor(panel_levels, levels = panel_levels),
+ ymin = ifelse(panel_levels == "Incremental fit (CFI & TLI)", incremental_ymin, 0.00),
+ ymax = ifelse(panel_levels == "Incremental fit (CFI & TLI)", incremental_ymax, approximation_ymax),
+ axis_label_y = ifelse(panel_levels == "Incremental fit (CFI & TLI)", incremental_ymin - (size_spec$axis_panel_offset + 0.004), -size_spec$axis_panel_offset),
+ stringsAsFactors = FALSE
+ )
+
+ bar_df <- merge(bar_df, axis_df, by = "Panel", all.x = TRUE, sort = FALSE)
+
+ if (!is.null(interval_source_df) && nrow(interval_source_df) > 0L) {
+ bar_df <- merge(bar_df, interval_source_df[, c("PLOT_ID", "Metric", "CI_low", "CI_high")], by = c("PLOT_ID", "Metric"), all.x = TRUE, sort = FALSE)
+ } else {
+ bar_df$CI_low <- NA_real_
+ bar_df$CI_high <- NA_real_
+ }
+
+ bar_df <- bar_df[order(bar_df$Panel, bar_df$metric_id, bar_df$PLOT_ID), ]
+ bar_df$label_anchor <- bar_df$Value
+ marker_df <- NULL
+ if (isTRUE(show_variant_shape)) {
+ marker_df <- bar_df[is.finite(bar_df$Value), c('PLOT_ID', 'MODEL_BASE', 'VARIANT', 'Metric', 'Panel', 'x', 'Value', 'ymin', 'ymax', 'CI_high'), drop = FALSE]
+ marker_df$shape_code <- unname(shape_values[marker_df$VARIANT])
+ marker_df$marker_x <- ifelse(marker_df$Metric == 'RMSEA' & is.finite(marker_df$CI_high), marker_df$x + group_layout$half_width * 0.38, marker_df$x)
+ marker_df$inside_scale <- ifelse(marker_df$Panel == "Approximation error (RMSEA & SRMR)", 0.62, 1.00)
+ marker_df$placement <- mapply(
+ plot_model_fit_bar_marker_placement,
+ value = marker_df$Value,
+ ymin = marker_df$ymin,
+ ymax = marker_df$ymax,
+ USE.NAMES = FALSE
+ )
+ marker_df$marker_y <- mapply(
+ plot_model_fit_bar_marker_y,
+ value = marker_df$Value,
+ label_y = marker_df$Value,
+ ymin = marker_df$ymin,
+ ymax = marker_df$ymax,
+ shape_code = marker_df$shape_code,
+ placement = marker_df$placement,
+ USE.NAMES = FALSE
+ )
+
+ marker_key <- paste(marker_df$PLOT_ID, marker_df$Metric)
+ bar_key <- paste(bar_df$PLOT_ID, bar_df$Metric)
+ marker_idx <- match(bar_key, marker_key)
+ above_idx <- !is.na(marker_idx) & marker_df$placement[marker_idx] == "above"
+ bar_df$label_anchor[above_idx] <- marker_df$marker_y[marker_idx[above_idx]]
+ }
+
+ bar_df$label_y <- mapply(
+ plot_model_fit_bar_label_y,
+ anchor = bar_df$label_anchor,
+ ymin = bar_df$ymin,
+ ymax = bar_df$ymax,
+ threshold = bar_df$Threshold,
+ min_offset = ifelse(bar_df$Panel == "Incremental fit (CFI & TLI)", size_spec$upper_label_offset, size_spec$lower_label_offset)
+ )
+
+
+ threshold_df <- unique(bar_df[c("Panel", "Metric", "metric_id", "Threshold", "ThresholdLabel")])
+ metric_counts <- tapply(metric_panel$metric_id, metric_panel$Panel, max)
+ threshold_df <- merge(threshold_df, axis_df[, c("Panel", "ymax")], by = "Panel", all.x = TRUE, sort = FALSE)
+ threshold_df$label_x <- unname(metric_counts[as.character(threshold_df$Panel)]) + 0.49
+ threshold_df$label_above <- !duplicated(threshold_df$Panel)
+ threshold_offset <- ifelse(
+ threshold_df$Panel == "Incremental fit (CFI & TLI)",
+ size_spec$threshold_panel_offset,
+ size_spec$threshold_stack_offset
+ )
+ threshold_df$label_above <- ifelse(
+ threshold_df$label_above & (threshold_df$Threshold + threshold_offset > threshold_df$ymax),
+ FALSE,
+ threshold_df$label_above
+ )
+ threshold_df$label_y <- threshold_df$Threshold + ifelse(threshold_df$label_above, threshold_offset, -threshold_offset)
+ threshold_df$hjust <- 1
+ threshold_df$vjust <- ifelse(threshold_df$label_above, 0, 1)
+
+ axis_label_df <- merge(metric_panel[, c("Panel", "metric_id", "Metric")], axis_df[, c("Panel", "axis_label_y")], by = "Panel", all.x = TRUE, sort = FALSE)
+ names(axis_label_df)[names(axis_label_df) == "metric_id"] <- "x"
+ names(axis_label_df)[names(axis_label_df) == "Metric"] <- "label"
+
+ interval_df <- bar_df[is.finite(bar_df$CI_low) & is.finite(bar_df$CI_high), c("PLOT_ID", "Metric", "Panel", "x", "CI_low", "CI_high"), drop = FALSE]
+ if (nrow(interval_df) > 0L) {
+ interval_df$Panel <- factor(interval_df$Panel, levels = panel_levels)
+ }
+
+ axis_min_df <- data.frame(Panel = axis_df$Panel, x = 0.45, y = axis_df$ymin)
+ axis_max_df <- data.frame(Panel = axis_df$Panel, x = unname(metric_counts[as.character(axis_df$Panel)]) + 0.52, y = axis_df$ymax)
+
+ p <- ggplot2::ggplot() +
+ ggplot2::geom_rect(
+ data = bar_df[is.finite(bar_df$Value), , drop = FALSE],
+ ggplot2::aes(xmin = .data$xmin, xmax = .data$xmax, ymin = .data$ymin, ymax = .data$Value, fill = .data$MODEL_BASE),
+ color = "#4f4f4f",
+ linewidth = 0.35
+ ) +
+ ggplot2::geom_hline(
+ data = threshold_df,
+ ggplot2::aes(yintercept = .data$Threshold),
+ linewidth = 0.75,
+ linetype = "dashed",
+ color = "#5b5b5b"
+ )
+
+ if (!is.null(interval_df) && nrow(interval_df) > 0L) {
+ p <- p + ggplot2::geom_errorbar(
+ data = interval_df,
+ ggplot2::aes(x = .data$x, ymin = .data$CI_low, ymax = .data$CI_high),
+ inherit.aes = FALSE,
+ width = 0.06,
+ linewidth = 0.65,
+ color = "#202020"
+ )
+ }
+
+ if (isTRUE(show_variant_shape) && !is.null(marker_df) && nrow(marker_df) > 0L) {
+ p <- p + plot_model_fit_geom_bar_marker(
+ data = marker_df,
+ ggplot2::aes(x = .data$marker_x, y = .data$marker_y, shape_code = .data$shape_code, placement = .data$placement, inside_scale = .data$inside_scale),
+ inherit.aes = FALSE,
+ size = size_spec$variant_marker_size,
+ stroke = size_spec$variant_marker_stroke,
+ colour = '#202020',
+ fill = '#202020',
+ show.legend = FALSE
+ ) +
+ ggplot2::geom_point(
+ data = marker_df,
+ ggplot2::aes(x = .data$marker_x, y = .data$marker_y, shape = .data$VARIANT),
+ inherit.aes = FALSE,
+ alpha = 0,
+ size = size_spec$variant_marker_size,
+ stroke = size_spec$variant_marker_stroke,
+ color = '#202020',
+ show.legend = TRUE
+ )
+ }
+
+ p <- p +
+ ggplot2::geom_label(
+ data = bar_df[is.finite(bar_df$Value), , drop = FALSE],
+ ggplot2::aes(x = .data$x, y = .data$label_y, label = .data$ValueLabel),
+ color = "#202020",
+ fill = "#f7f7f7",
+ linewidth = 0,
+ label.padding = grid::unit(size_spec$label_padding, "lines"),
+ label.r = grid::unit(size_spec$label_radius, "lines"),
+ size = plot_model_fit_pt(size_spec$value_pt),
+ vjust = 0,
+ show.legend = FALSE
+ ) +
+ ggplot2::geom_text(
+ data = threshold_df,
+ ggplot2::aes(x = .data$label_x, y = .data$label_y, label = .data$ThresholdLabel),
+ inherit.aes = FALSE,
+ color = "#4a4a4a",
+ hjust = threshold_df$hjust,
+ vjust = threshold_df$vjust,
+ size = plot_model_fit_pt(size_spec$threshold_pt),
+ fontface = "bold"
+ ) +
+ ggplot2::geom_text(
+ data = axis_label_df,
+ ggplot2::aes(x = .data$x, y = -Inf, label = .data$label),
+ inherit.aes = FALSE,
+ size = plot_model_fit_pt(size_spec$metric_pt),
+ vjust = 1.35
+ ) +
+ ggplot2::geom_blank(data = axis_min_df, ggplot2::aes(x = .data$x, y = .data$y), inherit.aes = FALSE) +
+ ggplot2::geom_blank(data = axis_max_df, ggplot2::aes(x = .data$x, y = .data$y), inherit.aes = FALSE) +
+ ggplot2::facet_wrap(~Panel, ncol = 1, scales = "free_y", as.table = FALSE) +
+ ggplot2::scale_fill_manual(values = stats::setNames(model_spec$Fill, model_levels)) +
+ ggplot2::scale_x_continuous(breaks = NULL, labels = NULL, expand = plot_model_fit_bar_expand(max(metric_counts))) +
+ ggplot2::scale_y_continuous(
+ limits = plot_model_fit_group_bar_limits,
+ breaks = plot_model_fit_group_bar_breaks,
+ labels = plot_model_fit_group_bar_labels,
+ expand = ggplot2::expansion(mult = c(0, 0))
+ ) +
+ ggplot2::coord_cartesian(clip = "off") +
+ ggplot2::labs(title = "Model fit comparison", subtitle = "Grouped threshold bars", x = NULL, y = "Index value", fill = "Model", shape = if (show_variant_shape) "Variant" else NULL) +
+ ggplot2::theme_minimal(base_size = size_spec$base) +
+ ggplot2::theme(
+ plot.title.position = "plot",
+ panel.grid.minor = ggplot2::element_blank(),
+ strip.text = ggplot2::element_text(face = "bold", size = size_spec$strip),
+ plot.title = ggplot2::element_text(size = size_spec$title, face = "bold"),
+ plot.subtitle = ggplot2::element_text(size = size_spec$subtitle),
+ axis.text.y = ggplot2::element_text(size = size_spec$axis_y, color = "#4a4a4a"),
+ legend.text = ggplot2::element_text(size = size_spec$legend_pt),
+ legend.title = ggplot2::element_text(size = size_spec$legend_pt + 0.5),
+ legend.position = "right",
+ axis.text.x = ggplot2::element_blank(),
+ axis.ticks.x = ggplot2::element_blank()
+ )
+
+ if (isTRUE(show_variant_shape) && !is.null(marker_df) && nrow(marker_df) > 0L) {
+ p <- p + ggplot2::scale_shape_manual(values = shape_values) +
+ ggplot2::guides(shape = ggplot2::guide_legend(override.aes = list(alpha = 1, size = size_spec$variant_marker_size, colour = '#202020')))
+ }
+
+ p
+}
+
+plot_model_fit_heatmap_scorecard <- function(fit_df, metric_spec) {
+ metrics <- metric_spec$Metric
+ plot_levels <- unique(fit_df$PLOT_ID)
+ size_spec <- plot_model_fit_size_spec("heatmap", n_metrics = length(metrics), n_rows = length(plot_levels))
+ long_df <- do.call(rbind, lapply(seq_len(nrow(metric_spec)), function(i) {
+ row <- metric_spec[i, ]
+ values <- fit_df[[row$Metric]]
+ scores <- vapply(
+ values,
+ plot_model_fit_compute_band_score,
+ numeric(1),
+ direction = row$Direction,
+ poor = row$Poor,
+ good = row$Good,
+ ideal = row$Ideal
+ )
+ data.frame(
+ PLOT_ID = fit_df$PLOT_ID,
+ Metric = row$Metric,
+ Score = scores,
+ ValueLabel = ifelse(is.na(values), "", sprintf("%.3f", values)),
+ stringsAsFactors = FALSE
+ )
+ }))
+ long_df$PLOT_ID <- factor(long_df$PLOT_ID, levels = rev(plot_levels))
+ long_df$Metric <- factor(long_df$Metric, levels = metrics)
+
+ plot_layout <- list(
+ palette = c("#d73027", "#f0b16b", "#efe3ae", "#c9dca8", "#8fc48d"),
+ palette_values = c(-1, -0.15, 0.25, 0.75, 1),
+ legend_breaks = c(-0.65, 0.18, 0.97),
+ legend_labels = c("Poor", "Good", "Ideal"),
+ legend_title = "Fit band",
+ legend_barwidth = grid::unit(6.4, "cm"),
+ legend_barheight = grid::unit(0.55, "cm")
+ )
+
+ ggplot2::ggplot(long_df, ggplot2::aes(x = .data$Metric, y = .data$PLOT_ID, fill = .data$Score)) +
+ ggplot2::geom_tile(color = "#f4f4f4", linewidth = 2.2, width = 0.99, height = 0.99) +
+ ggplot2::geom_text(
+ ggplot2::aes(label = .data$ValueLabel),
+ size = plot_model_fit_pt(size_spec$cell_pt),
+ fontface = "bold",
+ color = "#1f1f1f"
+ ) +
+ ggplot2::scale_fill_gradientn(
+ colours = plot_layout$palette,
+ values = plot_model_fit_rescale(plot_layout$palette_values),
+ limits = c(-1, 1),
+ breaks = plot_layout$legend_breaks,
+ labels = plot_layout$legend_labels,
+ name = plot_layout$legend_title,
+ guide = ggplot2::guide_colorbar(
+ title.position = "top",
+ title.hjust = 0.5,
+ barwidth = plot_layout$legend_barwidth,
+ barheight = plot_layout$legend_barheight,
+ ticks = FALSE,
+ frame.colour = "#d8d8d8"
+ )
+ ) +
+ ggplot2::labs(title = "Model fit comparison", subtitle = "Heatmap scorecard", x = NULL, y = NULL) +
+ ggplot2::theme_minimal(base_size = size_spec$base) +
+ ggplot2::theme(
+ plot.title.position = "plot",
+ plot.title = ggplot2::element_text(size = size_spec$title, face = "bold"),
+ plot.subtitle = ggplot2::element_text(size = size_spec$subtitle),
+ panel.grid = ggplot2::element_blank(),
+ axis.text.x = ggplot2::element_text(size = size_spec$axis_pt, face = "plain", color = "#4a4a4a"),
+ axis.text.y = ggplot2::element_text(size = size_spec$axis_pt, face = "plain", color = "#4a4a4a"),
+ legend.position = "bottom",
+ legend.direction = "horizontal",
+ legend.title = ggplot2::element_text(size = size_spec$legend_title_pt, hjust = 0.5, color = "#2f2f2f"),
+ legend.text = ggplot2::element_text(size = size_spec$legend_text_pt, color = "#2f2f2f"),
+ legend.box.margin = ggplot2::margin(t = 6, r = 0, b = 0, l = 0),
+ legend.margin = ggplot2::margin(0, 0, 0, 0)
+ )
+}
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/R/plot_model_fit.R b/R/plot_model_fit.R
new file mode 100644
index 0000000..0f63124
--- /dev/null
+++ b/R/plot_model_fit.R
@@ -0,0 +1,61 @@
+#' Plot fit indices from `psymetrics` fit objects
+#'
+#' @description
+#' `plot_model_fit()` is the public plotting entrypoint for fit-index
+#' objects created by [model_fit()] and [compare_model_fit()].
+#' In `v0.5.0`, it supports exactly two classes:
+#' - `model_fit` for one fitted model, including multi-row test summaries
+#' - `compare_model_fit` for two or more fitted models, including multi-row test summaries
+#'
+#' The default plot style is chosen automatically after applying `test_mode`.
+#' For `model_fit`, the default is a single-fit bullet chart when one row
+#' remains, and a threshold-aware dot plot otherwise. For `compare_model_fit`,
+#' the default is always the threshold-aware dot plot.
+#'
+#' @param x A `model_fit` or `compare_model_fit` object.
+#' @param type Character string indicating the plot style.
+#' Supported values are `"default"`, `"bullet"`, `"dots"`, `"bars"`,
+#' and `"heatmap"`.
+#' @param metrics Optional character vector selecting which fit indices to plot.
+#' Supported metrics are `"CFI"`, `"TLI"`, `"RMSEA"`, and `"SRMR"`.
+#' Defaults to `NULL`, which uses those metrics in canonical order when they
+#' are present in the object.
+#' @param test_mode Character string controlling which test rows are plotted when
+#' the input contains multiple rows per model. Supported values are `"all"`,
+#' `"non_standard"`, `"standard_only"`, and `"primary"`.
+#' Defaults to `"all"`.
+#' @param verbose Logical. If `TRUE`, non-fatal informational messages are shown
+#' when requested metrics are unavailable and dropped.
+#' @param ... Reserved for future extensions. Currently ignored.
+#'
+#' @return A `ggplot` object.
+#' @importFrom rlang .data
+#' @seealso [model_fit()], [compare_model_fit()], and [plot_factor_loadings()].
+#' @export
+#' @examples
+#' if (requireNamespace("lavaan", quietly = TRUE)) {
+#' library(lavaan)
+#' library(psymetrics)
+#'
+#' hs_model <- 'visual =~ x1 + x2 + x3
+#' textual =~ x4 + x5 + x6
+#' speed =~ x7 + x8 + x9'
+#'
+#' fit_mlr <- cfa(hs_model, data = HolzingerSwineford1939, estimator = "MLR")
+#' fit_ulsm <- cfa(hs_model, data = HolzingerSwineford1939, estimator = "ULSM")
+#'
+#' single_fit <- model_fit(fit_mlr)
+#' plot_model_fit(single_fit)
+#'
+#' compared_fits <- compare_model_fit(MLR = fit_mlr, ULSM = fit_ulsm)
+#' plot_model_fit(compared_fits)
+#' plot_model_fit(compared_fits, type = "bars")
+#' }
+plot_model_fit <- function(x, type = "default", metrics = NULL, test_mode = "all", verbose = TRUE, ...) {
+ UseMethod("plot_model_fit")
+}
+
+#' @export
+plot_model_fit.default <- function(x, type = "default", metrics = NULL, test_mode = "all", verbose = TRUE, ...) {
+ plot_model_fit_validate_input(x)
+}
diff --git a/README.Rmd b/README.Rmd
index dd9e27d..0fbcffd 100644
--- a/README.Rmd
+++ b/README.Rmd
@@ -23,7 +23,7 @@ knitr::opts_chunk$set(
`psymetrics` provides unified tools for psychometric model fit analysis,
-parameter extraction, and reporting workflows.
+parameter extraction, reporting, and visualization workflows.
## Installation
@@ -31,8 +31,8 @@ Install the development version from GitHub:
``` r
# install.packages("pak")
-pak::pak("brianmsm/psymetrics@v0.4.0")
-#remotes::install_github("brianmsm/psymetrics@v0.4.0")
+pak::pak("brianmsm/psymetrics@v0.5.0")
+#remotes::install_github("brianmsm/psymetrics@v0.5.0")
```
## Quick examples
@@ -63,6 +63,13 @@ Compare models:
compare_model_fit(MLR = fit_mlr, ULSM = fit_ulsm)
```
+Plot fit indices:
+
+```{r, eval=FALSE}
+compared_fits <- compare_model_fit(MLR = fit_mlr, ULSM = fit_ulsm)
+plot_model_fit(compared_fits)
+```
+
Extract parameter estimates:
```{r, eval=FALSE}
@@ -103,3 +110,5 @@ compared_estimates
+
+
diff --git a/README.md b/README.md
index feafc28..70de0d3 100644
--- a/README.md
+++ b/README.md
@@ -10,7 +10,7 @@
`psymetrics` provides unified tools for psychometric model fit analysis,
-parameter extraction, and reporting workflows.
+parameter extraction, reporting, and visualization workflows.
## Installation
@@ -18,8 +18,8 @@ Install the development version from GitHub:
``` r
# install.packages("pak")
-pak::pak("brianmsm/psymetrics@v0.4.0")
-#remotes::install_github("brianmsm/psymetrics@v0.4.0")
+pak::pak("brianmsm/psymetrics@v0.5.0")
+#remotes::install_github("brianmsm/psymetrics@v0.5.0")
```
## Quick examples
@@ -50,6 +50,13 @@ Compare models:
compare_model_fit(MLR = fit_mlr, ULSM = fit_ulsm)
```
+Plot fit indices:
+
+``` r
+compared_fits <- compare_model_fit(MLR = fit_mlr, ULSM = fit_ulsm)
+plot_model_fit(compared_fits)
+```
+
Extract parameter estimates:
``` r
@@ -90,5 +97,3 @@ compared_estimates
- Reporting + visualization article:
- Development roadmap: [ROADMAP.md](ROADMAP.md)
-
-
diff --git a/_pkgdown.yml b/_pkgdown.yml
index 6246338..d7fe19e 100644
--- a/_pkgdown.yml
+++ b/_pkgdown.yml
@@ -62,6 +62,7 @@ reference:
- save_table
- title: Visualization
contents:
+ - plot_model_fit
- plot_factor_loadings
- plot.lavaan
- plot-methods
@@ -69,10 +70,5 @@ reference:
contents:
- print.model_fit
- print.compare_model_fit
- - print.compare_model_estimates
- print.model_estimates
-
-
-
-
-
+ - print.compare_model_estimates
diff --git a/index.md b/index.md
index f02b3ef..27ef861 100644
--- a/index.md
+++ b/index.md
@@ -4,11 +4,10 @@ title: "psymetrics: Psychometric Model Fit and Reporting Tools"
# psymetrics: Psychometric Model Fit and Reporting Tools
-
+
`psymetrics` provides a unified workflow to inspect psychometric model fit,
-compare fitted models, extract parameter estimates, and generate publication-ready
-outputs.
+compare fitted models, extract parameter estimates, generate plots, and produce publication-ready outputs.
## Current scope
@@ -17,6 +16,7 @@ The package currently focuses on `lavaan` CFA and SEM workflows.
- Stable now:
- Fit extraction with `model_fit()`
- Fit comparison with `compare_model_fit()`
+ - Fit visualization with `plot_model_fit()`
- Parameter extraction with `model_estimates()`
- Parameter comparison with `compare_model_estimates()`
- Reporting with `format_results()` and `save_table()`
@@ -29,7 +29,7 @@ The package currently focuses on `lavaan` CFA and SEM workflows.
```r
# install.packages("pak")
-pak::pak("brianmsm/psymetrics@v0.4.0")
+pak::pak("brianmsm/psymetrics@v0.5.0")
```
## Recommended path
@@ -46,7 +46,7 @@ pak::pak("brianmsm/psymetrics@v0.4.0")
- [Reporting and visualization](articles/reporting-and-visualization.html)
- API reference: [Reference](reference/index.html)
- Changes by release: [News](news/index.html)
-- Project roadmap: [ROADMAP](https://github.com/brianmsm/psymetrics/blob/main/ROADMAP.md)
+- Project roadmap: [ROADMAP](ROADMAP.html)
## Contributing
@@ -56,6 +56,3 @@ Issues and feature requests are welcome:
- Feature requests: include the target workflow and expected output.
GitHub issues:
-
-
-
diff --git a/man/plot.lavaan.Rd b/man/plot.lavaan.Rd
index f99d2c6..a12c0d1 100644
--- a/man/plot.lavaan.Rd
+++ b/man/plot.lavaan.Rd
@@ -38,9 +38,9 @@ plotting functions.}
}
\value{
A ggplot object for \code{factor_loadings} and \code{residuals}
-plots if \code{ggplot2} is installed, or a \code{semPlot} diagram
-object for \code{path} plots. An error message will be returned
-if required packages are not available.
+plots, or a \code{semPlot} diagram object for \code{path} plots.
+An error message will be returned if other required packages
+are not available.
}
\description{
This is a plot method for fitted \code{lavaan} objects, including
@@ -65,8 +65,7 @@ estimated relationships between them.
}
}
\examples{
-if (requireNamespace("lavaan", quietly = TRUE) &&
- requireNamespace("ggplot2", quietly = TRUE)) {
+if (requireNamespace("lavaan", quietly = TRUE)) {
library(lavaan)
library(psymetrics)
hs_model <- 'visual =~ x1 + x2 + x3
@@ -74,8 +73,6 @@ if (requireNamespace("lavaan", quietly = TRUE) &&
speed =~ x7 + x8 + x9'
fit <- cfa(hs_model, data = HolzingerSwineford1939, estimator = "MLR")
plot(fit)
-} else {
- message("Please install 'lavaan' and 'ggplot2' to run this example.")
}
}
\seealso{
diff --git a/man/plot_factor_loadings.Rd b/man/plot_factor_loadings.Rd
index 3416e4b..7ce4f91 100644
--- a/man/plot_factor_loadings.Rd
+++ b/man/plot_factor_loadings.Rd
@@ -72,8 +72,7 @@ errors are still raised.}
\item{...}{Additional arguments passed to \code{ggplot2::ggplot}.}
}
\value{
-A ggplot object if \code{ggplot2} is installed, otherwise
-an error message.
+A ggplot object.
}
\description{
Creates a dot plot of standardized factor loadings
@@ -84,8 +83,7 @@ intervals for each item. If the model does not contain
\verb{=~} parameters, the function errors with a clear message.
}
\examples{
-if (requireNamespace("lavaan", quietly = TRUE) &&
- requireNamespace("ggplot2", quietly = TRUE)) {
+if (requireNamespace("lavaan", quietly = TRUE)) {
library(lavaan)
library(psymetrics)
hs_model <- 'visual =~ x1 + x2 + x3
@@ -100,8 +98,6 @@ if (requireNamespace("lavaan", quietly = TRUE) &&
speed ~ textual'
fit_sem <- sem(sem_model, data = HolzingerSwineford1939, group = "school")
plot_factor_loadings(fit_sem, facet_by = "group")
-} else {
- message("Please install 'lavaan' and 'ggplot2' to run this example.")
}
}
\seealso{
diff --git a/man/plot_model_fit.Rd b/man/plot_model_fit.Rd
new file mode 100644
index 0000000..5705c56
--- /dev/null
+++ b/man/plot_model_fit.Rd
@@ -0,0 +1,77 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/plot_model_fit.R
+\name{plot_model_fit}
+\alias{plot_model_fit}
+\title{Plot fit indices from \code{psymetrics} fit objects}
+\usage{
+plot_model_fit(
+ x,
+ type = "default",
+ metrics = NULL,
+ test_mode = "all",
+ verbose = TRUE,
+ ...
+)
+}
+\arguments{
+\item{x}{A \code{model_fit} or \code{compare_model_fit} object.}
+
+\item{type}{Character string indicating the plot style.
+Supported values are \code{"default"}, \code{"bullet"}, \code{"dots"}, \code{"bars"},
+and \code{"heatmap"}.}
+
+\item{metrics}{Optional character vector selecting which fit indices to plot.
+Supported metrics are \code{"CFI"}, \code{"TLI"}, \code{"RMSEA"}, and \code{"SRMR"}.
+Defaults to \code{NULL}, which uses those metrics in canonical order when they
+are present in the object.}
+
+\item{test_mode}{Character string controlling which test rows are plotted when
+the input contains multiple rows per model. Supported values are \code{"all"},
+\code{"non_standard"}, \code{"standard_only"}, and \code{"primary"}.
+Defaults to \code{"all"}.}
+
+\item{verbose}{Logical. If \code{TRUE}, non-fatal informational messages are shown
+when requested metrics are unavailable and dropped.}
+
+\item{...}{Reserved for future extensions. Currently ignored.}
+}
+\value{
+A \code{ggplot} object.
+}
+\description{
+\code{plot_model_fit()} is the public plotting entrypoint for fit-index
+objects created by \code{\link[=model_fit]{model_fit()}} and \code{\link[=compare_model_fit]{compare_model_fit()}}.
+In \code{v0.5.0}, it supports exactly two classes:
+\itemize{
+\item \code{model_fit} for one fitted model, including multi-row test summaries
+\item \code{compare_model_fit} for two or more fitted models, including multi-row test summaries
+}
+
+The default plot style is chosen automatically after applying \code{test_mode}.
+For \code{model_fit}, the default is a single-fit bullet chart when one row
+remains, and a threshold-aware dot plot otherwise. For \code{compare_model_fit},
+the default is always the threshold-aware dot plot.
+}
+\examples{
+if (requireNamespace("lavaan", quietly = TRUE)) {
+ library(lavaan)
+ library(psymetrics)
+
+ hs_model <- 'visual =~ x1 + x2 + x3
+ textual =~ x4 + x5 + x6
+ speed =~ x7 + x8 + x9'
+
+ fit_mlr <- cfa(hs_model, data = HolzingerSwineford1939, estimator = "MLR")
+ fit_ulsm <- cfa(hs_model, data = HolzingerSwineford1939, estimator = "ULSM")
+
+ single_fit <- model_fit(fit_mlr)
+ plot_model_fit(single_fit)
+
+ compared_fits <- compare_model_fit(MLR = fit_mlr, ULSM = fit_ulsm)
+ plot_model_fit(compared_fits)
+ plot_model_fit(compared_fits, type = "bars")
+}
+}
+\seealso{
+\code{\link[=model_fit]{model_fit()}}, \code{\link[=compare_model_fit]{compare_model_fit()}}, and \code{\link[=plot_factor_loadings]{plot_factor_loadings()}}.
+}
diff --git a/tests/manual/sem_stress_lavaan.R b/tests/manual/sem_stress_lavaan.R
index eeb29de..897fb4f 100644
--- a/tests/manual/sem_stress_lavaan.R
+++ b/tests/manual/sem_stress_lavaan.R
@@ -13,8 +13,6 @@ if (!requireNamespace("lavaan", quietly = TRUE)) {
devtools::load_all(".", quiet = TRUE)
-has_ggplot2 <- requireNamespace("ggplot2", quietly = TRUE)
-
results <- data.frame(
case = character(),
action = character(),
@@ -290,11 +288,6 @@ for (fit_name in names(fits)) {
)
}
- if (!isTRUE(has_ggplot2)) {
- record_result(fit_name, "plot_factor_loadings", "skipped_no_ggplot2", note = "ggplot2 not installed.")
- next
- }
-
if (identical(fit_name, "sem_path_only")) {
run_action(
fit_name,
diff --git a/tests/testthat/test-plot-lavaan.R b/tests/testthat/test-plot-lavaan.R
index 6f26eb2..b0189a0 100644
--- a/tests/testthat/test-plot-lavaan.R
+++ b/tests/testthat/test-plot-lavaan.R
@@ -1,6 +1,5 @@
test_that("plot_factor_loadings returns ggplot", {
skip_if_not_installed("lavaan")
- skip_if_not_installed("ggplot2")
model <- "visual =~ x1 + x2 + x3 + x4"
fit <- suppressWarnings(
@@ -25,7 +24,6 @@ test_that("plot.lavaan errors on unsupported type", {
test_that("plot_factor_loadings errors clearly for non-lavaan objects", {
skip_if_not_installed("lavaan")
- skip_if_not_installed("ggplot2")
fit <- stats::lm(mpg ~ wt, data = mtcars)
@@ -37,7 +35,6 @@ test_that("plot_factor_loadings errors clearly for non-lavaan objects", {
test_that("plot_factor_loadings respects ci alias and ci_bounds messaging", {
skip_if_not_installed("lavaan")
- skip_if_not_installed("ggplot2")
model <- "visual =~ x1 + x2 + x3 + x4"
fit <- suppressWarnings(
@@ -53,7 +50,6 @@ test_that("plot_factor_loadings respects ci alias and ci_bounds messaging", {
test_that("plot_factor_loadings arrow uses 0-1 when all values are non-negative", {
skip_if_not_installed("lavaan")
- skip_if_not_installed("ggplot2")
model <- "visual =~ x1 + x2 + x3 + x4"
fit <- suppressWarnings(
@@ -85,7 +81,6 @@ test_that("plot_factor_loadings arrow uses 0-1 when all values are non-negative"
test_that("plot_factor_loadings warns for non-converged models", {
skip_if_not_installed("lavaan")
- skip_if_not_installed("ggplot2")
model <- "visual =~ x1 + x2 + x3 + x4"
fit <- suppressWarnings(
@@ -109,7 +104,6 @@ test_that("plot_factor_loadings warns for non-converged models", {
test_that("plot_factor_loadings is silent with verbose = FALSE for non-converged SEM", {
skip_if_not_installed("lavaan")
- skip_if_not_installed("ggplot2")
sem_model <- "
visual =~ x1 + x2 + x3
@@ -168,7 +162,6 @@ speed ~ visual + textual
test_that("plot_factor_loadings is silent for standardized = FALSE with verbose = FALSE", {
skip_if_not_installed("lavaan")
- skip_if_not_installed("ggplot2")
sem_model <- "
visual =~ x1 + x2 + x3
@@ -231,7 +224,6 @@ test_that("plot_factor_loadings is silent for standardized = FALSE with verbose
test_that("plot_factor_loadings supports standardized = FALSE", {
skip_if_not_installed("lavaan")
- skip_if_not_installed("ggplot2")
model <- "visual =~ x1 + x2 + x3 + x4"
fit <- suppressWarnings(
@@ -258,7 +250,6 @@ test_that("plot_factor_loadings supports standardized = FALSE", {
test_that("plot_factor_loadings supports group_by = FALSE", {
skip_if_not_installed("lavaan")
- skip_if_not_installed("ggplot2")
model <- "visual =~ x1 + x2 + x3 + x4"
fit <- suppressWarnings(
@@ -277,7 +268,6 @@ test_that("plot_factor_loadings supports group_by = FALSE", {
test_that("plot_factor_loadings supports sort = FALSE", {
skip_if_not_installed("lavaan")
- skip_if_not_installed("ggplot2")
model <- "visual =~ x1 + x2 + x3 + x4"
fit <- suppressWarnings(
@@ -300,7 +290,6 @@ test_that("plot_factor_loadings supports sort = FALSE", {
test_that("plot_factor_loadings maps est.std to est by name", {
skip_if_not_installed("lavaan")
- skip_if_not_installed("ggplot2")
model <- "visual =~ x1 + x2 + x3 + x4"
fit <- suppressWarnings(
@@ -326,7 +315,6 @@ test_that("plot_factor_loadings maps est.std to est by name", {
test_that("plot_factor_loadings errors for lavaan models without =~ loadings", {
skip_if_not_installed("lavaan")
- skip_if_not_installed("ggplot2")
path_data <- transform(mtcars, x1 = wt, x2 = hp, y = mpg)
fit <- suppressWarnings(
diff --git a/tests/testthat/test-plot-model-fit.R b/tests/testthat/test-plot-model-fit.R
new file mode 100644
index 0000000..b77c3f9
--- /dev/null
+++ b/tests/testthat/test-plot-model-fit.R
@@ -0,0 +1,514 @@
+local_plot_model_fit_objects <- function() {
+ skip_if_not_installed("lavaan")
+
+ hs_data <- lavaan::HolzingerSwineford1939
+ model_1 <- "visual =~ x1 + x2 + x3 + x4"
+ model_2 <- "visual =~ x1 + x2 + x3
+textual =~ x4 + x5 + x6"
+
+ fit_1 <- suppressWarnings(
+ lavaan::cfa(model_1, data = hs_data, estimator = "MLR")
+ )
+ fit_2 <- suppressWarnings(
+ lavaan::cfa(model_2, data = hs_data, estimator = "MLR")
+ )
+
+ list(
+ single = psymetrics::model_fit(fit_1),
+ compare = psymetrics::compare_model_fit(MLR = fit_1, SEM = fit_2)
+ )
+}
+
+local_plot_model_fit_metadata_objects <- function() {
+ skip_if_not_installed("lavaan")
+
+ hs_data <- lavaan::HolzingerSwineford1939
+ standard_model <- "visual =~ x1 + x2 + x3 + x4"
+ robust_model_1 <- "visual =~ x1 + x2 + x3
+textual =~ x4 + x5 + x6"
+ robust_model_2 <- "visual =~ x1 + x2 + x3 + x4
+textual =~ x5 + x6 + x7"
+
+ fit_standard <- suppressWarnings(
+ lavaan::cfa(standard_model, data = hs_data, estimator = "ML")
+ )
+ fit_nonstandard <- suppressWarnings(
+ lavaan::cfa(robust_model_1, data = hs_data, estimator = "MLR")
+ )
+ fit_multi_1 <- suppressWarnings(
+ lavaan::cfa(
+ robust_model_1,
+ data = hs_data,
+ estimator = "MLR",
+ test = c("satorra.bentler", "mean.var.adjusted")
+ )
+ )
+ fit_multi_2 <- suppressWarnings(
+ lavaan::cfa(
+ robust_model_2,
+ data = hs_data,
+ estimator = "MLR",
+ test = c("satorra.bentler", "mean.var.adjusted")
+ )
+ )
+
+ list(
+ single_standard = psymetrics::model_fit(fit_standard),
+ single_nonstandard = psymetrics::model_fit(fit_nonstandard),
+ single_multi = psymetrics::model_fit(fit_multi_1, standard_test = TRUE),
+ compare_multi = psymetrics::compare_model_fit(
+ First = fit_multi_1,
+ Second = fit_multi_2,
+ standard_test = TRUE
+ )
+ )
+}
+
+local_plot_model_fit_attach_metadata <- function(x, test_role, is_primary) {
+ psymetrics:::model_fit_attach_test_metadata(
+ x,
+ test_role = test_role,
+ is_primary = is_primary
+ )
+}
+
+local_plot_model_fit_multirow_objects <- function() {
+ single <- data.frame(
+ ESTIMATOR = c("ML", "MLR", "MLR"),
+ TEST = c("standard", "satorra.bentler", "mean.var.adjusted"),
+ CFI = c(0.901, 0.925, 0.919),
+ TLI = c(0.892, 0.914, 0.909),
+ RMSEA = c(0.081, 0.067, 0.072),
+ RMSEA_CI_low = c(0.071, 0.055, 0.060),
+ RMSEA_CI_high = c(0.091, 0.079, 0.084),
+ SRMR = c(0.061, 0.054, 0.056),
+ converged = c(TRUE, TRUE, TRUE),
+ stringsAsFactors = FALSE
+ )
+ class(single) <- c("model_fit", "data.frame")
+ single <- local_plot_model_fit_attach_metadata(
+ single,
+ test_role = c("standard", "non_standard", "non_standard"),
+ is_primary = c(FALSE, TRUE, FALSE)
+ )
+
+ compare <- data.frame(
+ MODEL = c("MLR", "MLR", "ULSM", "ULSM"),
+ ESTIMATOR = c("ML", "MLR", "ULS", "ULSM"),
+ TEST = c("standard", "satorra.bentler", "standard", "mean.var.adjusted"),
+ CFI = c(0.901, 0.925, 0.907, 0.931),
+ TLI = c(0.892, 0.914, 0.899, 0.921),
+ RMSEA = c(0.081, 0.067, 0.077, 0.059),
+ RMSEA_CI_low = c(0.071, 0.055, 0.065, 0.049),
+ RMSEA_CI_high = c(0.091, 0.079, 0.089, 0.071),
+ SRMR = c(0.061, 0.054, 0.063, 0.050),
+ converged = c(TRUE, TRUE, TRUE, TRUE),
+ stringsAsFactors = FALSE
+ )
+ class(compare) <- c("compare_model_fit", "model_fit", "data.frame")
+ compare <- local_plot_model_fit_attach_metadata(
+ compare,
+ test_role = c("standard", "non_standard", "standard", "non_standard"),
+ is_primary = c(FALSE, TRUE, FALSE, TRUE)
+ )
+
+ estimator_only <- data.frame(
+ MODEL = c("M1", "M1"),
+ ESTIMATOR = c("ML", "MLR"),
+ CFI = c(0.90, 0.93),
+ TLI = c(0.89, 0.92),
+ RMSEA = c(0.08, 0.06),
+ RMSEA_CI_low = c(0.07, 0.05),
+ RMSEA_CI_high = c(0.09, 0.07),
+ SRMR = c(0.06, 0.05),
+ converged = c(TRUE, TRUE),
+ stringsAsFactors = FALSE
+ )
+ class(estimator_only) <- c("compare_model_fit", "model_fit", "data.frame")
+
+ duplicate_estimator <- data.frame(
+ MODEL = c("M1", "M1"),
+ ESTIMATOR = c("MLR", "MLR"),
+ CFI = c(0.90, 0.91),
+ TLI = c(0.89, 0.90),
+ RMSEA = c(0.08, 0.07),
+ RMSEA_CI_low = c(0.07, 0.06),
+ RMSEA_CI_high = c(0.09, 0.08),
+ SRMR = c(0.06, 0.05),
+ converged = c(TRUE, TRUE),
+ stringsAsFactors = FALSE
+ )
+ class(duplicate_estimator) <- c("compare_model_fit", "model_fit", "data.frame")
+
+ list(single = single, compare = compare, estimator_only = estimator_only, duplicate_estimator = duplicate_estimator)
+}
+
+test_that("plot_model_fit defaults work for model_fit and build successfully", {
+ objects <- local_plot_model_fit_objects()
+
+ plot_single <- psymetrics::plot_model_fit(objects$single)
+
+ expect_s3_class(plot_single, "ggplot")
+ expect_no_error(ggplot2::ggplot_build(plot_single))
+ expect_equal(plot_single$labels$subtitle, "Single-fit bullet chart")
+})
+
+test_that("plot_model_fit defaults work for compare_model_fit and preserve model order", {
+ objects <- local_plot_model_fit_objects()
+
+ plot_compare <- psymetrics::plot_model_fit(objects$compare)
+
+ expect_s3_class(plot_compare, "ggplot")
+ expect_no_error(ggplot2::ggplot_build(plot_compare))
+ expect_equal(plot_compare$labels$subtitle, "Threshold-aware dot plot")
+
+ compare_df <- psymetrics:::plot_model_fit_prepare_data(
+ objects$compare,
+ c("CFI", "TLI", "RMSEA", "SRMR"),
+ "compare_model_fit",
+ "all"
+ )
+ expect_equal(unique(compare_df$MODEL_BASE), unique(objects$compare$MODEL))
+})
+
+test_that("plot_model_fit supports all valid types and bullet only for single-row summaries", {
+ objects <- local_plot_model_fit_objects()
+ multi <- local_plot_model_fit_multirow_objects()
+
+ expect_no_error(ggplot2::ggplot_build(psymetrics::plot_model_fit(objects$single, type = "bullet")))
+ expect_no_error(ggplot2::ggplot_build(psymetrics::plot_model_fit(objects$single, type = "dots")))
+ expect_no_error(ggplot2::ggplot_build(psymetrics::plot_model_fit(objects$compare, type = "dots")))
+ expect_no_error(ggplot2::ggplot_build(psymetrics::plot_model_fit(objects$compare, type = "bars")))
+ expect_no_error(ggplot2::ggplot_build(psymetrics::plot_model_fit(objects$compare, type = "heatmap")))
+ expect_error(
+ psymetrics::plot_model_fit(multi$compare, type = "bullet"),
+ "requires a single-row fit summary"
+ )
+})
+
+test_that("plot_model_fit uses canonical metric order when metrics is NULL", {
+ fake_single <- data.frame(
+ CFI = 0.91,
+ RMSEA = 0.07,
+ RMSEA_CI_low = 0.05,
+ RMSEA_CI_high = 0.09,
+ converged = TRUE,
+ stringsAsFactors = FALSE
+ )
+ class(fake_single) <- c("model_fit", "data.frame")
+
+ plot_single <- psymetrics::plot_model_fit(fake_single)
+ built_single <- ggplot2::ggplot_build(plot_single)
+
+ expect_equal(
+ as.character(built_single[["layout"]][["layout"]][["Metric"]]),
+ c("CFI", "RMSEA")
+ )
+})
+
+test_that("plot_model_fit preserves user metric order for subsets", {
+ objects <- local_plot_model_fit_objects()
+
+ plot_single <- psymetrics::plot_model_fit(objects$single, metrics = c("SRMR", "CFI"))
+ built_single <- ggplot2::ggplot_build(plot_single)
+ expect_equal(
+ as.character(built_single[["layout"]][["layout"]][["Metric"]]),
+ c("SRMR", "CFI")
+ )
+
+ plot_heatmap <- psymetrics::plot_model_fit(objects$compare, type = "heatmap", metrics = c("SRMR", "CFI"))
+ expect_equal(levels(plot_heatmap$data$Metric), c("SRMR", "CFI"))
+})
+
+test_that("plot_model_fit errors on unsupported metric names", {
+ objects <- local_plot_model_fit_objects()
+
+ expect_error(
+ psymetrics::plot_model_fit(objects$single, metrics = c("CFI", "AIC")),
+ "Unsupported metric name"
+ )
+})
+
+test_that("plot_model_fit uses RMSEA confidence intervals when available", {
+ objects <- local_plot_model_fit_objects()
+ multi <- local_plot_model_fit_multirow_objects()
+
+ single_with_ci <- psymetrics::plot_model_fit(objects$single, metrics = "RMSEA")
+ single_without_object <- objects$single
+ single_without_object$RMSEA_CI_low <- NULL
+ single_without_object$RMSEA_CI_high <- NULL
+ single_without_ci <- psymetrics::plot_model_fit(single_without_object, metrics = "RMSEA")
+
+ compare_with_ci <- psymetrics::plot_model_fit(objects$compare, metrics = "RMSEA")
+ compare_without_object <- objects$compare
+ compare_without_object$RMSEA_CI_low <- NULL
+ compare_without_object$RMSEA_CI_high <- NULL
+ compare_without_ci <- psymetrics::plot_model_fit(compare_without_object, metrics = "RMSEA")
+
+ grouped_with_ci <- psymetrics::plot_model_fit(multi$compare, type = "bars", metrics = c("RMSEA", "SRMR"))
+ grouped_without_object <- multi$compare
+ grouped_without_object$RMSEA_CI_low <- NULL
+ grouped_without_object$RMSEA_CI_high <- NULL
+ grouped_without_ci <- psymetrics::plot_model_fit(grouped_without_object, type = "bars", metrics = c("RMSEA", "SRMR"))
+
+ expect_gt(length(single_with_ci$layers), length(single_without_ci$layers))
+ expect_gt(length(compare_with_ci$layers), length(compare_without_ci$layers))
+ expect_gt(length(grouped_with_ci$layers), length(grouped_without_ci$layers))
+ expect_no_error(ggplot2::ggplot_build(single_with_ci))
+ expect_no_error(ggplot2::ggplot_build(compare_with_ci))
+ expect_no_error(ggplot2::ggplot_build(grouped_with_ci))
+})
+
+test_that("plot_model_fit does not crash on non-converged fit objects when metrics exist", {
+ fake_single <- data.frame(
+ CFI = 0.91,
+ TLI = 0.90,
+ RMSEA = 0.07,
+ RMSEA_CI_low = 0.05,
+ RMSEA_CI_high = 0.09,
+ SRMR = 0.06,
+ converged = FALSE,
+ stringsAsFactors = FALSE
+ )
+ class(fake_single) <- c("model_fit", "data.frame")
+
+ fake_compare <- data.frame(
+ MODEL = c("M1", "M2"),
+ CFI = c(0.91, 0.94),
+ TLI = c(0.90, 0.93),
+ RMSEA = c(0.07, 0.06),
+ RMSEA_CI_low = c(0.05, 0.04),
+ RMSEA_CI_high = c(0.09, 0.08),
+ SRMR = c(0.06, 0.05),
+ converged = c(FALSE, FALSE),
+ stringsAsFactors = FALSE
+ )
+ class(fake_compare) <- c("compare_model_fit", "model_fit", "data.frame")
+
+ expect_no_error(ggplot2::ggplot_build(psymetrics::plot_model_fit(fake_single)))
+ expect_no_error(ggplot2::ggplot_build(psymetrics::plot_model_fit(fake_compare)))
+})
+
+test_that("plot_model_fit handles multi-row objects through test_mode and default type", {
+ multi <- local_plot_model_fit_multirow_objects()
+
+ plot_single_all <- psymetrics::plot_model_fit(multi$single)
+ plot_single_primary <- psymetrics::plot_model_fit(multi$single, test_mode = "primary")
+ plot_compare_all <- psymetrics::plot_model_fit(multi$compare)
+
+ expect_equal(plot_single_all$labels$subtitle, "Threshold-aware dot plot")
+ expect_equal(plot_single_primary$labels$subtitle, "Single-fit bullet chart")
+ expect_equal(plot_compare_all$labels$subtitle, "Threshold-aware dot plot")
+
+ single_all_df <- psymetrics:::plot_model_fit_prepare_data(multi$single, c("CFI", "TLI", "RMSEA", "SRMR"), "model_fit", "all")
+ compare_all_df <- psymetrics:::plot_model_fit_prepare_data(multi$compare, c("CFI", "TLI", "RMSEA", "SRMR"), "compare_model_fit", "all")
+ expect_true(all(single_all_df$PLOT_ID != single_all_df$MODEL_BASE))
+ expect_true(all(compare_all_df$PLOT_ID != compare_all_df$MODEL_BASE))
+})
+
+test_that("plot_model_fit test_mode filters rows as intended", {
+ multi <- local_plot_model_fit_multirow_objects()
+ metrics <- c("CFI", "TLI", "RMSEA", "SRMR")
+
+ all_df <- psymetrics:::plot_model_fit_prepare_data(multi$single, metrics, "model_fit", "all")
+ non_standard_df <- psymetrics:::plot_model_fit_prepare_data(multi$single, metrics, "model_fit", "non_standard")
+ standard_df <- psymetrics:::plot_model_fit_prepare_data(multi$single, metrics, "model_fit", "standard_only")
+ primary_df <- psymetrics:::plot_model_fit_prepare_data(multi$single, metrics, "model_fit", "primary")
+
+ expect_equal(nrow(all_df), 3)
+ expect_equal(non_standard_df$TEST, c("satorra.bentler", "mean.var.adjusted"))
+ expect_equal(standard_df$TEST, "standard")
+ expect_equal(primary_df$TEST, "satorra.bentler")
+})
+
+test_that("plot_model_fit uses metadata for one-row summaries without TEST", {
+ objects <- local_plot_model_fit_metadata_objects()
+ metrics <- c("CFI", "TLI", "RMSEA", "SRMR")
+
+ single_standard_df <- psymetrics:::plot_model_fit_prepare_data(objects$single_standard, metrics, "model_fit", "standard_only")
+ expect_equal(nrow(single_standard_df), 1)
+ expect_equal(single_standard_df$MODEL_BASE, "Model")
+ expect_equal(single_standard_df$ESTIMATOR, "ML")
+
+ expect_error(
+ psymetrics:::plot_model_fit_prepare_data(objects$single_standard, metrics, "model_fit", "non_standard"),
+ "left no rows available to plot"
+ )
+
+ single_nonstandard_df <- psymetrics:::plot_model_fit_prepare_data(objects$single_nonstandard, metrics, "model_fit", "non_standard")
+ expect_equal(nrow(single_nonstandard_df), 1)
+ expect_equal(single_nonstandard_df$ESTIMATOR, "MLR")
+
+ expect_error(
+ psymetrics:::plot_model_fit_prepare_data(objects$single_nonstandard, metrics, "model_fit", "standard_only"),
+ "left no rows available to plot"
+ )
+})
+
+test_that("plot_model_fit uses metadata for multi-row summaries without TEST", {
+ objects <- local_plot_model_fit_metadata_objects()
+ metrics <- c("CFI", "TLI", "RMSEA", "SRMR")
+
+ standard_df <- psymetrics:::plot_model_fit_prepare_data(objects$single_multi, metrics, "model_fit", "standard_only")
+ non_standard_df <- psymetrics:::plot_model_fit_prepare_data(objects$single_multi, metrics, "model_fit", "non_standard")
+ primary_df <- psymetrics:::plot_model_fit_prepare_data(objects$single_multi, metrics, "model_fit", "primary")
+
+ expect_equal(standard_df$ESTIMATOR, "ML")
+ expect_equal(non_standard_df$ESTIMATOR, c("MLR", "satorra.bentler", "mean.var.adjusted"))
+ expect_equal(primary_df$ESTIMATOR, "MLR")
+})
+
+test_that("plot_model_fit re-aligns metadata after reordering compare_model_fit rows", {
+ objects <- local_plot_model_fit_metadata_objects()
+ metrics <- c("CFI", "TLI", "RMSEA", "SRMR")
+
+ second_idx <- which(objects$compare_multi$MODEL == "Second")
+ first_idx <- which(objects$compare_multi$MODEL == "First")
+ reordered_compare <- objects$compare_multi[c(second_idx, first_idx), , drop = FALSE]
+ reordered_compare$MODEL <- c(
+ rep("Zeta", length(second_idx)),
+ rep("Alpha", length(first_idx))
+ )
+
+ compare_standard_df <- psymetrics:::plot_model_fit_prepare_data(reordered_compare, metrics, "compare_model_fit", "standard_only")
+ compare_primary_df <- psymetrics:::plot_model_fit_prepare_data(reordered_compare, metrics, "compare_model_fit", "primary")
+
+ expect_equal(unique(compare_standard_df$MODEL_BASE), c("Zeta", "Alpha"))
+ expect_equal(compare_standard_df$ESTIMATOR, c("ML", "ML"))
+ expect_equal(compare_primary_df$ESTIMATOR, c("MLR", "MLR"))
+})
+
+test_that("plot_model_fit derives variant labels from TEST, ESTIMATOR, or row fallback", {
+ multi <- local_plot_model_fit_multirow_objects()
+ metrics <- c("CFI", "TLI", "RMSEA", "SRMR")
+
+ compare_df <- psymetrics:::plot_model_fit_prepare_data(multi$compare, metrics, "compare_model_fit", "all")
+ estimator_df <- psymetrics:::plot_model_fit_prepare_data(multi$estimator_only, metrics, "compare_model_fit", "all")
+ duplicate_df <- psymetrics:::plot_model_fit_prepare_data(multi$duplicate_estimator, metrics, "compare_model_fit", "all")
+
+ expect_true(all(compare_df$VARIANT %in% c("standard", "satorra.bentler", "mean.var.adjusted")))
+ expect_equal(estimator_df$VARIANT, c("ML", "MLR"))
+ expect_true(all(grepl("Row", duplicate_df$VARIANT)))
+})
+
+test_that("plot_model_fit assigns exact cutoff values to the better CFI/TLI band", {
+ band_df <- psymetrics:::plot_model_fit_single_band_spec(c("CFI", "TLI", "RMSEA", "SRMR"))
+
+ expect_equal(psymetrics:::plot_model_fit_assign_band("CFI", 0.90, band_df), "Acceptable")
+ expect_equal(psymetrics:::plot_model_fit_assign_band("CFI", 0.95, band_df), "Good")
+ expect_equal(psymetrics:::plot_model_fit_assign_band("TLI", 0.90, band_df), "Acceptable")
+ expect_equal(psymetrics:::plot_model_fit_assign_band("TLI", 0.95, band_df), "Good")
+ expect_equal(psymetrics:::plot_model_fit_assign_band("RMSEA", 0.05, band_df), "Good")
+ expect_equal(psymetrics:::plot_model_fit_assign_band("RMSEA", 0.08, band_df), "Acceptable")
+})
+
+test_that("plot_model_fit internal auto breaks stay close to the approved plotting behavior", {
+ expect_equal(
+ psymetrics:::plot_model_fit_auto_breaks("CFI", 0.80, 1.00),
+ c(0.80, 0.85, 0.90, 0.95, 1.00)
+ )
+ expect_equal(
+ psymetrics:::plot_model_fit_auto_breaks("TLI", 0.70, 1.00),
+ c(0.70, 0.80, 0.90, 1.00)
+ )
+ expect_equal(
+ psymetrics:::plot_model_fit_auto_breaks("RMSEA", 0.00, 0.223),
+ c(0.00, 0.05, 0.10, 0.15, 0.20)
+ )
+})
+
+test_that("plot_model_fit grouped-bar axis helpers and marker fallback use the new thresholds", {
+ expect_equal(psymetrics:::plot_model_fit_choose_incremental_ymin(c(0.82, 0.91)), 0.80)
+ expect_equal(psymetrics:::plot_model_fit_choose_incremental_ymin(c(0.803, 0.91)), 0.75)
+ expect_equal(psymetrics:::plot_model_fit_choose_incremental_ymin(c(0.68, 0.77)), 0.65)
+ expect_equal(psymetrics:::plot_model_fit_choose_incremental_ymax(c(0.98, 1.02)), 1.05)
+
+ expect_equal(psymetrics:::plot_model_fit_choose_error_ymax(c(0.060, 0.072), ci_high = c(0.070, 0.082)), 0.10)
+ expect_equal(psymetrics:::plot_model_fit_choose_error_ymax(c(0.160, 0.172), ci_high = c(0.175, 0.187)), 0.20)
+ expect_equal(psymetrics:::plot_model_fit_group_bar_limits(c(-0.014, 0.082)), c(0.00, 0.08))
+ expect_equal(psymetrics:::plot_model_fit_group_bar_limits(c(0.728, 0.981)), c(0.75, 1.00))
+ expect_equal(psymetrics:::plot_model_fit_group_bar_limits(c(0.728, 1.02)), c(0.75, 1.05))
+ expect_equal(psymetrics:::plot_model_fit_group_bar_limits(c(-0.014, 0.092)), c(0.00, 0.10))
+ expect_equal(psymetrics:::plot_model_fit_group_bar_breaks(c(0.75, 1.00)), c(0.75, 0.80, 0.85, 0.90, 0.95, 1.00))
+ expect_equal(psymetrics:::plot_model_fit_group_bar_breaks(c(0.75, 1.05)), c(0.75, 0.80, 0.85, 0.90, 0.95, 1.00))
+ expect_equal(psymetrics:::plot_model_fit_group_bar_breaks(c(0.00, 0.08)), c(0.00, 0.02, 0.04, 0.05, 0.06, 0.08))
+ expect_equal(psymetrics:::plot_model_fit_group_bar_labels(c(1.00, 0.90, 0.08)), c("1.00", "0.90", "0.08"))
+
+ expect_equal(psymetrics:::plot_model_fit_bar_marker_placement(0.006, 0.00, 0.08), "above")
+ expect_equal(psymetrics:::plot_model_fit_bar_marker_placement(0.009, 0.00, 0.08), "inside")
+ expect_gt(
+ psymetrics:::plot_model_fit_bar_marker_y(0.006, 0.006, 0.00, 0.08, shape_code = 16, placement = "above"),
+ 0.006
+ )
+ expect_equal(
+ psymetrics:::plot_model_fit_bar_marker_y(0.009, 0.009, 0.00, 0.08, shape_code = 16, placement = "inside"),
+ 0.009
+ )
+})
+
+test_that("plot_model_fit dots uses color by model and keeps variant shapes without a legend", {
+ multi <- local_plot_model_fit_multirow_objects()
+
+ plot_compare <- psymetrics::plot_model_fit(multi$compare, type = "dots")
+ expect_equal(plot_compare$labels$colour, "Model")
+ expect_null(plot_compare$labels$shape)
+ expect_true(any(vapply(plot_compare$scales$scales, function(x) "shape" %in% x$aesthetics, logical(1))))
+ expect_no_error(ggplot2::ggplot_build(plot_compare))
+})
+
+test_that("plot_model_fit bars and heatmap build cleanly for multi-row compare objects", {
+ multi <- local_plot_model_fit_multirow_objects()
+
+ expect_no_error(ggplot2::ggplot_build(psymetrics::plot_model_fit(multi$compare, type = "bars")))
+ expect_no_error(ggplot2::ggplot_build(psymetrics::plot_model_fit(multi$compare, type = "heatmap")))
+})
+
+test_that("plot_model_fit bars preserves panel-specific metric counts for subset metrics", {
+ multi <- local_plot_model_fit_multirow_objects()
+
+ plot_bars <- psymetrics::plot_model_fit(multi$compare, type = "bars", metrics = c("CFI", "TLI", "RMSEA"))
+ built <- ggplot2::ggplot_build(plot_bars)
+
+ axis_max_df <- built$data[[length(built$data)]][, c("PANEL", "x")]
+ panel_layout <- built$layout$layout[, c("PANEL", "Panel")]
+ axis_max_df$Panel <- panel_layout$Panel[match(axis_max_df$PANEL, panel_layout$PANEL)]
+ axis_max_by_panel <- stats::setNames(axis_max_df$x, axis_max_df$Panel)
+
+ expect_equal(unname(axis_max_by_panel["Incremental fit (CFI & TLI)"]), 2.52)
+ expect_equal(unname(axis_max_by_panel["Approximation error (RMSEA & SRMR)"]), 1.52)
+})
+
+test_that("plot_model_fit bars preserves incremental values above 1.00 while keeping axis labels capped at 1.00", {
+ multi <- local_plot_model_fit_multirow_objects()
+ multi$compare$CFI[1] <- 1.02
+
+ built <- ggplot2::ggplot_build(psymetrics::plot_model_fit(multi$compare, type = "bars"))
+ panel_layout <- built$layout$layout[, c("PANEL", "Panel")]
+ incremental_panel <- panel_layout$PANEL[panel_layout$Panel == "Incremental fit (CFI & TLI)"]
+ rect_df <- built$data[[1]]
+ incremental_scale <- built$layout$panel_scales_y[[incremental_panel]]
+
+ expect_true(any(abs(rect_df$ymax[rect_df$PANEL == incremental_panel] - 1.02) < 1e-9))
+ expect_equal(incremental_scale$get_limits(), c(0.80, 1.05))
+ expect_equal(incremental_scale$get_breaks(), c(0.80, 0.85, 0.90, 0.95, 1.00))
+})
+
+test_that("plot_model_fit surfaces guided errors for raw fits and invalid test_mode results", {
+ fit <- lm(mpg ~ wt, data = mtcars)
+ multi <- local_plot_model_fit_multirow_objects()
+
+ expect_error(
+ psymetrics::plot_model_fit(fit),
+ "requires a `model_fit` or `compare_model_fit` object, not a raw fitted model"
+ )
+ expect_no_error(
+ psymetrics::plot_model_fit(multi$single, test_mode = "standard_only", type = "bars", metrics = c("CFI"), verbose = FALSE)
+ )
+
+ only_non_standard <- multi$single[multi$single$TEST != "standard", , drop = FALSE]
+ class(only_non_standard) <- class(multi$single)
+ expect_error(
+ psymetrics::plot_model_fit(only_non_standard, test_mode = "standard_only"),
+ "left no rows available to plot"
+ )
+})
diff --git a/tests/testthat/test-sem-support.R b/tests/testthat/test-sem-support.R
index 9a7f246..9f7e0b3 100644
--- a/tests/testthat/test-sem-support.R
+++ b/tests/testthat/test-sem-support.R
@@ -38,7 +38,6 @@ s =~ 0*t1 + 1*t2 + 2*t3 + 3*t4
test_that("canonical PoliticalDemocracy SEM works across core functions", {
skip_if_not_installed("lavaan")
- skip_if_not_installed("ggplot2")
fit_sem_mlr <- suppressWarnings(
lavaan::sem(sem_political_model, data = lavaan::PoliticalDemocracy, estimator = "MLR")
@@ -116,7 +115,6 @@ test_that("SEM robust ML estimators return valid model_fit outputs", {
test_that("categorical SEM with WLSMV works across fit and plotting", {
skip_if_not_installed("lavaan")
- skip_if_not_installed("ggplot2")
hs_ord <- lavaan::HolzingerSwineford1939
ordered_vars <- paste0("x", 1:9)
@@ -144,7 +142,6 @@ test_that("categorical SEM with WLSMV works across fit and plotting", {
test_that("multigroup SEM supports facet_by = group", {
skip_if_not_installed("lavaan")
- skip_if_not_installed("ggplot2")
fit <- suppressWarnings(
lavaan::sem(
@@ -166,7 +163,6 @@ test_that("multigroup SEM supports facet_by = group", {
test_that("multilevel SEM supports facet_by = level", {
skip_if_not_installed("lavaan")
- skip_if_not_installed("ggplot2")
fit <- suppressWarnings(
lavaan::sem(
@@ -350,7 +346,6 @@ test_that("non-converged SEM keeps stable outputs for model_fit and compare_mode
test_that("growth models are supported by model_fit and plot_factor_loadings", {
skip_if_not_installed("lavaan")
- skip_if_not_installed("ggplot2")
fit <- suppressWarnings(
lavaan::growth(growth_model, data = lavaan::Demo.growth)
@@ -391,7 +386,6 @@ test_that("growth models work with compare_model_fit", {
test_that("path-only SEM errors in plot_factor_loadings and plot.lavaan", {
skip_if_not_installed("lavaan")
- skip_if_not_installed("ggplot2")
path_data <- transform(mtcars, x1 = wt, x2 = hp, y = mpg)
fit_path <- suppressWarnings(
@@ -429,7 +423,6 @@ test_that("path-only SEM errors in plot_factor_loadings and plot.lavaan", {
test_that("facet_by falls back with informative message when metadata is unavailable", {
skip_if_not_installed("lavaan")
- skip_if_not_installed("ggplot2")
fit <- suppressWarnings(
lavaan::sem(sem_hs_model, data = lavaan::HolzingerSwineford1939, estimator = "ML")
@@ -448,7 +441,6 @@ test_that("facet_by falls back with informative message when metadata is unavail
test_that("facet_by fallback stays silent when verbose = FALSE", {
skip_if_not_installed("lavaan")
- skip_if_not_installed("ggplot2")
fit <- suppressWarnings(
lavaan::sem(sem_hs_model, data = lavaan::HolzingerSwineford1939, estimator = "ML")