Skip to content

Add format() method to parameters_efa objects #1236

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
strengejacke merged 5 commits into from
Jun 28, 2026
Merged

Add format() method to parameters_efa objects #1236

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
5 commits
Select commit Hold shift + click to select a range
c233ef6
Add format() method to parameters_efa objects
strengejacke Jun 28, 2026
5a181ef
format returns data frame
strengejacke Jun 28, 2026
cba8c2b
add test
strengejacke Jun 28, 2026
756b73d
fixes
strengejacke Jun 28, 2026
e1c6573
add test
strengejacke Jun 28, 2026
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
3 changes: 3 additions & 0 deletions NAMESPACE
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -173,8 +173,11 @@ S3method(format,equivalence_test_lm)
S3method(format,p_calibrate)
S3method(format,parameters_brms_meta)
S3method(format,parameters_coef)
S3method(format,parameters_efa)
S3method(format,parameters_model)
S3method(format,parameters_omega)
S3method(format,parameters_p_function)
S3method(format,parameters_pca)
S3method(format,parameters_sem)
S3method(format,parameters_simulate)
S3method(format,parameters_standardized)
Expand Down
3 changes: 3 additions & 0 deletions NEWS.md
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -5,6 +5,9 @@
* `simulate_model()`, `simulate_parameters()` and `equivalence_test()` now work
for `lavaan` objects.

* Added `format()` method for objects returned by `factor_analysis()` and
`principal_components()`.

## Bug fixes

* Fixed issues with extracting wrong standard errors for model with frailty
Expand Down
24 changes: 24 additions & 0 deletions R/format.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -3,7 +3,7 @@
#' @inheritParams print.parameters_model
#' @rdname print.parameters_model
#' @export
format.parameters_model <- function(

Check warning on line 6 in R/format.R

View workflow job for this annotation

GitHub Actions / lint-changed-files / lint-changed-files 

file=R/format.R,line=6,col=1,[cyclocomp_linter] Reduce the cyclomatic complexity of this expression from 67 to at most 40. Consider replacing high-complexity sections like loops and branches with helper functions.
x,
pretty_names = TRUE,
split_components = TRUE,
Expand Down Expand Up @@ -259,7 +259,7 @@
#' @rdname print.compare_parameters
#' @inheritParams print.parameters_model
#' @export
format.compare_parameters <- function(

Check warning on line 262 in R/format.R

View workflow job for this annotation

GitHub Actions / lint-changed-files / lint-changed-files 

file=R/format.R,line=262,col=1,[cyclocomp_linter] Reduce the cyclomatic complexity of this expression from 41 to at most 40. Consider replacing high-complexity sections like loops and branches with helper functions.
x,
split_components = TRUE,
select = NULL,
Expand Down Expand Up @@ -478,6 +478,30 @@
formatted_table
}

# PCA/FA-models ---------------------------------

#' @export
format.parameters_pca <- function(x, labels = NULL, threshold = NULL, ...) {
# Labels
if (!is.null(labels)) {
x$Label <- labels
x <- x[c("Variable", "Label", names(x)[!names(x) %in% c("Variable", "Label")])]
}

# Replace by NA all cells below threshold
if (!is.null(threshold)) {
x <- .filter_loadings(x, threshold = threshold)
}

as.data.frame(x)
}
Comment on lines +484 to +497

@gemini-code-assist gemini-code-assist Bot Jun 28, 2026

Copy link
Copy Markdown
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

high

The sort argument and its corresponding sorting logic were removed from .print_parameters_cfa_efa but are not implemented in format.parameters_pca. As a result, calling print(..., sort = TRUE) will now silently ignore the sorting request.

To fix this, we should add the sort argument to format.parameters_pca and apply .sort_loadings(x) when sort = TRUE.

format.parameters_pca <- function(x, labels = NULL, threshold = NULL, sort = FALSE, ...) {
  # Sorting
  if (isTRUE(sort)) {
    x <- .sort_loadings(x)
  }

  # Labels
  if (!is.null(labels)) {
    x$Label <- labels
    x <- x[c("Variable", "Label", names(x)[!names(x) %in% c("Variable", "Label")])]
  }

  # Replace by NA all cells below threshold
  if (!is.null(threshold)) {
    x <- .filter_loadings(x, threshold = threshold)
  }

  x
}


#' @export
format.parameters_efa <- format.parameters_pca

#' @export
format.parameters_omega <- format.parameters_pca

# sem-models ---------------------------------

#' @export
Expand Down Expand Up @@ -708,7 +732,7 @@


# footer: type of uncertainty interval
.print_footer_cimethod <- function(x) {

Check warning on line 735 in R/format.R

View workflow job for this annotation

GitHub Actions / lint-changed-files / lint-changed-files 

file=R/format.R,line=735,col=1,[cyclocomp_linter] Reduce the cyclomatic complexity of this expression from 49 to at most 40. Consider replacing high-complexity sections like loops and branches with helper functions.
if (!isTRUE(getOption("parameters_cimethod", TRUE))) {
return()
}
Expand Down Expand Up @@ -926,5 +950,5 @@
"Some coefficients seem to be rather large, which may indicate issues with (quasi) complete separation. Consider using bias-corrected or penalized regression models."
)
}
return(NULL)

Check warning on line 953 in R/format.R

View workflow job for this annotation

GitHub Actions / lint-changed-files / lint-changed-files 

file=R/format.R,line=953,col=3,[return_linter] Use implicit return behavior; explicit return() is not needed.
}
194 changes: 110 additions & 84 deletions R/print_html.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -2,29 +2,31 @@

#' @rdname print.parameters_model
#' @export
print_html.parameters_model <- function(x,
pretty_names = TRUE,
split_components = TRUE,
select = NULL,
caption = NULL,
subtitle = NULL,
footer = NULL,
align = NULL,
digits = 2,
ci_digits = digits,
p_digits = 3,
footer_digits = 3,
ci_brackets = c("(", ")"),
show_sigma = FALSE,
show_formula = FALSE,
zap_small = FALSE,
groups = NULL,
font_size = "100%",
line_padding = 4,
column_labels = NULL,
include_reference = FALSE,
verbose = TRUE,
...) {
print_html.parameters_model <- function(
x,
pretty_names = TRUE,
split_components = TRUE,
select = NULL,
caption = NULL,
subtitle = NULL,
footer = NULL,
align = NULL,
digits = 2,
ci_digits = digits,
p_digits = 3,
footer_digits = 3,
ci_brackets = c("(", ")"),
show_sigma = FALSE,
show_formula = FALSE,
zap_small = FALSE,
groups = NULL,
font_size = "100%",
line_padding = 4,
column_labels = NULL,
include_reference = FALSE,
verbose = TRUE,
...
) {
# which engine?
engine <- .check_format_backend(...)

Expand Down Expand Up @@ -66,7 +68,9 @@

# check if pretty names should be replaced by value labels
# (if we have labelled data)
if (isTRUE(getOption("parameters_labels", FALSE)) || identical(pretty_names, "labels")) {
if (
isTRUE(getOption("parameters_labels", FALSE)) || identical(pretty_names, "labels")
) {
attr(x, "pretty_names") <- attr(x, "pretty_labels", exact = TRUE)
pretty_names <- TRUE
}
Expand Down Expand Up @@ -99,8 +103,18 @@

# replace brackets by parenthesis
if (!is.null(ci_brackets) && "Parameter" %in% colnames(formatted_table)) {
formatted_table$Parameter <- gsub("[", ci_brackets[1], formatted_table$Parameter, fixed = TRUE)
formatted_table$Parameter <- gsub("]", ci_brackets[2], formatted_table$Parameter, fixed = TRUE)
formatted_table$Parameter <- gsub(
"[",
ci_brackets[1],
formatted_table$Parameter,
fixed = TRUE
)
formatted_table$Parameter <- gsub(
"]",
ci_brackets[2],
formatted_table$Parameter,
fixed = TRUE
)
}

# footer
Expand Down Expand Up @@ -152,21 +166,23 @@

#' @rdname print.compare_parameters
#' @export
print_html.compare_parameters <- function(x,
caption = NULL,
subtitle = NULL,
footer = NULL,
digits = 2,
ci_digits = digits,
p_digits = 3,
zap_small = FALSE,
groups = NULL,
select = NULL,
ci_brackets = c("(", ")"),
font_size = "100%",
line_padding = 4,
column_labels = NULL,
...) {
print_html.compare_parameters <- function(
x,
caption = NULL,
subtitle = NULL,
footer = NULL,
digits = 2,
ci_digits = digits,
p_digits = 3,
zap_small = FALSE,
groups = NULL,
select = NULL,
ci_brackets = c("(", ")"),
font_size = "100%",
line_padding = 4,
column_labels = NULL,
...
) {
# check if user supplied digits attributes
if (missing(digits)) {
digits <- .additional_arguments(x, "digits", digits)
Expand Down Expand Up @@ -211,15 +227,25 @@

# replace brackets by parenthesis
if (!is.null(ci_brackets) && "Parameter" %in% colnames(formatted_table)) {
formatted_table$Parameter <- gsub("[", ci_brackets[1], formatted_table$Parameter, fixed = TRUE)
formatted_table$Parameter <- gsub("]", ci_brackets[2], formatted_table$Parameter, fixed = TRUE)
formatted_table$Parameter <- gsub(
"[",
ci_brackets[1],
formatted_table$Parameter,
fixed = TRUE
)
formatted_table$Parameter <- gsub(
"]",
ci_brackets[2],
formatted_table$Parameter,
fixed = TRUE
)
}

# setup grouping for tt-backend --------------------------------------------
# --------------------------------------------------------------------------

model_groups <- NULL
by <- NULL

Check warning on line 248 in R/print_html.R

View workflow job for this annotation

GitHub Actions / lint-changed-files / lint-changed-files 

file=R/print_html.R,line=248,col=3,[object_overwrite_linter] 'by' is an exported object from package 'base'. Avoid re-using such symbols.

# find columns that contain model names, which we want to group
models <- setdiff(
Expand All @@ -243,10 +269,10 @@
}
}
if ("Component" %in% colnames(formatted_table)) {
by <- c(by, "Component")

Check warning on line 272 in R/print_html.R

View workflow job for this annotation

GitHub Actions / lint-changed-files / lint-changed-files 

file=R/print_html.R,line=272,col=5,[object_overwrite_linter] 'by' is an exported object from package 'base'. Avoid re-using such symbols.
}
if ("Effects" %in% colnames(formatted_table)) {
by <- c(by, "Effects")

Check warning on line 275 in R/print_html.R

View workflow job for this annotation

GitHub Actions / lint-changed-files / lint-changed-files 

file=R/print_html.R,line=275,col=5,[object_overwrite_linter] 'by' is an exported object from package 'base'. Avoid re-using such symbols.
}

# export table ------------------------------------------------------------
Expand Down Expand Up @@ -282,23 +308,22 @@

# PCA / EFA / CFA ----------------------------


#' @rdname principal_components
#' @export
print_html.parameters_efa <- function(x,
digits = 2,
sort = FALSE,
threshold = NULL,
labels = NULL,
...) {
print_html.parameters_efa <- function(
x,
digits = 2,
threshold = NULL,
labels = NULL,
...
) {
# extract attributes
if (is.null(threshold)) {
threshold <- attributes(x)$threshold
}
.print_parameters_cfa_efa(
x,
threshold = threshold,
sort = sort,
format = "html",
digits = digits,
labels = labels,
Expand All @@ -318,9 +343,20 @@
table_caption <- "(Explained) Variance of Components"

if ("Parameter" %in% names(x)) {
x$Parameter <- c("Eigenvalues", "Variance Explained", "Variance Explained (Cumulative)", "Variance Explained (Proportion)") # nolint
x$Parameter <- c(
"Eigenvalues",
"Variance Explained",
"Variance Explained (Cumulative)",
"Variance Explained (Proportion)"
) # nolint
} else if ("Component" %in% names(x)) {
names(x) <- c("Component", "Eigenvalues", "Variance Explained", "Variance Explained (Cumulative)", "Variance Explained (Proportion)") # nolint
names(x) <- c(
"Component",
"Eigenvalues",
"Variance Explained",
"Variance Explained (Cumulative)",
"Variance Explained (Proportion)"
) # nolint
}

# we may have factor correlations
Expand Down Expand Up @@ -372,34 +408,31 @@

#' @rdname p_function
#' @export
print_html.parameters_p_function <- function(x,
digits = 2,
ci_width = "auto",
ci_brackets = c("(", ")"),
pretty_names = TRUE,
...) {
.print_p_function(
x,
digits,
ci_width,
ci_brackets,
pretty_names,
format = "html",
...
)
print_html.parameters_p_function <- function(
x,
digits = 2,
ci_width = "auto",
ci_brackets = c("(", ")"),
pretty_names = TRUE,
...
) {
.print_p_function(x, digits, ci_width, ci_brackets, pretty_names, format = "html", ...)
}


# helper ------------------

.add_gt_options <- function(out,
style,
font_size = "100%",
line_padding = 4,
column_names = NULL,
user_labels = NULL) {
.add_gt_options <- function(
out,
style,
font_size = "100%",
line_padding = 4,
column_names = NULL,
user_labels = NULL
) {
insight::check_if_installed("gt")
out <- gt::tab_options(out,
out <- gt::tab_options(
out,
table.font.size = font_size,
data_row.padding = gt::px(line_padding)
)
Expand Down Expand Up @@ -448,15 +481,8 @@
# add a border to the first column.
out <- gt::tab_style(
out,
style = gt::cell_borders(
sides = "right",
style = "solid",
color = "#d3d3d3"
),
locations = gt::cells_body(
columns = pcol_name,
rows = 1:last_row
)
style = gt::cell_borders(sides = "right", style = "solid", color = "#d3d3d3"),
locations = gt::cells_body(columns = pcol_name, rows = 1:last_row)
)
out
}
Expand Down
Loading
Loading