add-plot-model-fit

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,17 +24,18 @@ Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.3.3
 Imports: 
     cli,
+    ggplot2,
     insight,
     methods,
     rlang,
     tinytable
 Suggests: 
     lavaan,
     knitr,
-    ggplot2,
     flextable,
     officer,
     testthat (>= 3.0.0)
 Depends: 
     R (>= 4.1.0)
 Config/testthat/edition: 3
+

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)

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.
+
+

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
   )

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))
 

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())

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,17 +52,14 @@
 #'     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
 #'                textual =~ x4 + x5 + x6
 #'                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.")
   }