Rename cor into correlation_matrix

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: parameters
 Title: Processing of Model Parameters
-Version: 0.26.0.2
+Version: 0.26.0.3
 Authors@R:
     c(person(given = "Daniel",
              family = "Lüdecke",
@@ -115,6 +115,7 @@ Suggests:
     curl,
     dbscan,
     did,
+    discovr,
     distributional,
     domir (>= 0.2.0),
     drc,

NAMESPACE

@@ -604,8 +604,12 @@ S3method(print,parameters_simulate)
 S3method(print,parameters_standardized)
 S3method(print_html,compare_parameters)
 S3method(print_html,parameters_brms_meta)
+S3method(print_html,parameters_efa)
+S3method(print_html,parameters_efa_summary)
 S3method(print_html,parameters_model)
 S3method(print_html,parameters_p_function)
+S3method(print_html,parameters_pca)
+S3method(print_html,parameters_pca_summary)
 S3method(print_html,parameters_sem)
 S3method(print_html,parameters_simulate)
 S3method(print_html,parameters_standardized)

NEWS.md

@@ -1,3 +1,19 @@
+# parameters (devel)
+
+## Breaking Changes
+
+* The `cor` argument in `n_factors()` was renamed into `correlation_matrix`. In
+  `factor_analysis()`, the `cor` argument was completely removed to avoid naming
+  collision with the `cor` argument of `psych::fa()`, which now users can pass
+  the `cor` argument to `psych::fa()` when using `factor_analysis()`.
+
+## Changes
+
+* Added and/or improved print-methods for all functions around PCA and FA.
+
+* Improved efficiency in `model_parameters()` for models from packages *brms*
+  and *rstanarm*.
+
 # parameters 0.26.0
 
 ## Changes

R/display.R

@@ -107,26 +107,28 @@
                                      ...) {
   format <- insight::validate_argument(format, c("markdown", "html", "md", "tt"))
 
+  fun_args <- list(
+    x = object, pretty_names = pretty_names, split_components = split_components,
+    select = select, digits = digits, caption = caption, subtitle = subtitle,
+    footer = footer, ci_digits = ci_digits, p_digits = p_digits,
+    footer_digits = footer_digits, ci_brackets = ci_brackets,
+    show_sigma = show_sigma, show_formula = show_formula, zap_small = zap_small,
+    include_reference = include_reference, verbose = verbose
+  )
+
   if (format %in% c("html", "tt")) {
-    print_html(
-      x = object, pretty_names = pretty_names, split_components = split_components,
-      select = select, digits = digits, caption = caption, subtitle = subtitle,
-      footer = footer, ci_digits = ci_digits, p_digits = p_digits,
-      footer_digits = footer_digits, align = align, ci_brackets = ci_brackets,
-      show_sigma = show_sigma, show_formula = show_formula, zap_small = zap_small,
-      font_size = font_size, line_padding = line_padding,
-      column_labels = column_labels, include_reference = include_reference,
-      verbose = verbose, ...
+    fun_args <- c(
+      fun_args,
+      list(
+        column_labels = column_labels,
+        align = align,
+        font_size = font_size,
+        line_padding = line_padding
+      )
     )
+    do.call(print_html, c(fun_args, list(...)))
   } else {
-    print_md(
-      x = object, pretty_names = pretty_names, split_components = split_components,
-      select = select, digits = digits, caption = caption, subtitle = subtitle,
-      footer = footer, ci_digits = ci_digits, p_digits = p_digits,
-      footer_digits = footer_digits, ci_brackets = ci_brackets,
-      show_sigma = show_sigma, show_formula = show_formula, zap_small = zap_small,
-      include_reference = include_reference, verbose = verbose, ...
-    )
+    do.call(print_md, c(fun_args, list(...)))
   }
 }
 
@@ -155,15 +157,29 @@
                                        ...) {
   format <- insight::validate_argument(format, c("markdown", "html", "md", "tt"))
 
+  fun_args <- list(
+    x = object,
+    digits = digits,
+    ci_digits = ci_digits,
+    p_digits = p_digits,
+    ci_brackets = ci_brackets,
+    select = select,
+    zap_small = zap_small
+  )
+
   if (format %in% c("html", "tt")) {
-    print_html(
-      x = object, digits = digits, ci_digits = ci_digits, p_digits = p_digits,
-      select = select, column_labels = column_labels, font_size = font_size,
-      line_padding = line_padding, ci_brackets = ci_brackets,
-      zap_small = zap_small, ...
+    fun_args <- c(
+      fun_args,
+      list(
+        column_labels = column_labels,
+        align = align,
+        font_size = font_size,
+        line_padding = line_padding
+      )
     )
+    do.call(print_html, c(fun_args, list(...)))
   } else {
-    print_md(x = object, digits = digits, ci_digits = ci_digits, p_digits = p_digits, select = select, ...)
+    do.call(print_md, c(fun_args, list(...)))
   }
 }
 
@@ -180,7 +196,21 @@
                                    p_digits = 3,
                                    ci_brackets = c("(", ")"),
                                    ...) {
-  print_md(x = object, digits = digits, ci_digits = ci_digits, p_digits = p_digits, ci_brackets = ci_brackets, ...)
+  format <- insight::validate_argument(format, c("markdown", "html", "md", "tt"))
+
+  fun_args <- list(
+    x = object,
+    digits = digits,
+    ci_digits = ci_digits,
+    p_digits = p_digits,
+    ci_brackets = ci_brackets
+  )
+
+  if (format %in% c("html", "tt")) {
+    do.call(print_html, c(fun_args, list(...)))
+  } else {
+    do.call(print_md, c(fun_args, list(...)))
+  }
 }
 
 
@@ -190,7 +220,14 @@
 #' @rdname display.parameters_model
 #' @export
 display.parameters_efa_summary <- function(object, format = "markdown", digits = 3, ...) {
-  print_md(x = object, digits = digits, ...)
+  format <- insight::validate_argument(format, c("markdown", "html", "md", "tt"))
+  fun_args <- list(x = object, digits = digits)
+
+  if (format %in% c("html", "tt")) {
+    do.call(print_html, c(fun_args, list(...)))
+  } else {
+    do.call(print_md, c(fun_args, list(...)))
+  }
 }
 
 #' @export
@@ -200,8 +237,22 @@
 #' @inheritParams model_parameters.principal
 #' @rdname display.parameters_model
 #' @export
 display.parameters_efa <- function(object, format = "markdown", digits = 2, sort = FALSE, threshold = NULL, labels = NULL, ...) {
-  print_md(x = object, digits = digits, sort = sort, threshold = threshold, labels = labels, ...)
+  format <- insight::validate_argument(format, c("markdown", "html", "md", "tt"))
+
+  fun_args <- list(
+    x = object,
+    digits = digits,
+    sort = sort,
+    threshold = threshold,
+    labels = labels
+  )
+
+  if (format %in% c("html", "tt")) {
+    do.call(print_html, c(fun_args, list(...)))
+  } else {
+    do.call(print_md, c(fun_args, list(...)))
+  }
 }
 
 #' @export

R/factor_analysis.R

@@ -1,83 +1,41 @@
 #' @rdname principal_components
 #' @export
-factor_analysis <- function(x,
-                            n = "auto",
-                            rotation = "none",
-                            sort = FALSE,
-                            threshold = NULL,
-                            standardize = TRUE,
-                            cor = NULL,
-                            ...) {
+factor_analysis <- function(x, ...) {
   UseMethod("factor_analysis")
 }
 
 
+#' @rdname principal_components
 #' @export
 factor_analysis.data.frame <- function(x,
                                        n = "auto",
                                        rotation = "none",
                                        sort = FALSE,
                                        threshold = NULL,
                                        standardize = TRUE,
-                                       cor = NULL,
                                        ...) {
+  insight::check_if_installed("psych")
+
   # Standardize
-  if (standardize && is.null(cor)) {
+  if (standardize) {
     x <- datawizard::standardize(x, ...)
   }
 
   # N factors
-  n <- .get_n_factors(x, n = n, type = "FA", rotation = rotation, cor = cor)
-
-  .factor_analysis_rotate(
+  n <- .get_n_factors(
     x,
-    n,
-    rotation = rotation,
-    sort = sort,
+    n = n,
+    type = "FA",
+    rotation = rotation
+  )
+
+  # FA
+  out <- model_parameters(
+    psych::fa(x, nfactors = n, rotate = rotation, ...),
     threshold = threshold,
-    cor = cor,
+    sort = sort,
     ...
   )
-}
-
-
-#' @keywords internal
-.factor_analysis_rotate <- function(x,
-                                    n,
-                                    rotation,
-                                    sort = FALSE,
-                                    threshold = NULL,
-                                    cor = NULL,
-                                    ...) {
-  if (!inherits(x, "data.frame")) {
-    insight::format_error("`x` must be a data frame.")
-  }
-
-  # rotate loadings
-  if (!requireNamespace("psych", quietly = TRUE)) {
-    insight::format_error(sprintf("Package `psych` required for `%s`-rotation.", rotation))
-  }
-
-  # Pass cor if available
-  if (is.null(cor)) {
-    out <- model_parameters(
-      psych::fa(x, nfactors = n, rotate = rotation, ...),
-      sort = sort,
-      threshold = threshold
-    )
-  } else {
-    out <- model_parameters(
-      psych::fa(
-        cor,
-        nfactors = n,
-        rotate = rotation,
-        n.obs = nrow(x),
-        ...
-      ),
-      sort = sort,
-      threshold = threshold
-    )
-  }
 
   attr(out, "dataset") <- x
   out

R/methods_psych.R

@@ -155,34 +155,19 @@
   n <- model$factors
 
   # Get summary
-  variance <- as.data.frame(unclass(model$Vaccounted))
-  data_summary <- .data_frame(
-    Component = names(variance),
-    Eigenvalues = model$values[1:n],
-    Variance = as.numeric(variance["Proportion Var", ])
-  )
-  if ("Cumulative Var" %in% row.names(variance)) {
-    data_summary$Variance_Cumulative <- as.numeric(variance["Cumulative Var", ])
-  } else {
-    if (ncol(variance) == 1) {
-      data_summary$Variance_Cumulative <- as.numeric(variance["Proportion Var", ])
-    } else {
-      data_summary$Variance_Cumulative <- NA
-    }
-  }
-  data_summary$Variance_Proportion <- data_summary$Variance / sum(data_summary$Variance)
+  data_summary <- .get_fa_variance_summary(model)
 
   # Get loadings
   loadings <- as.data.frame(unclass(model$loadings))
 
   # Format
   loadings <- cbind(data.frame(Variable = row.names(loadings)), loadings)
   row.names(loadings) <- NULL
 
   # Labels
   if (!is.null(labels)) {
     loadings$Label <- labels
     loadings <- loadings[c("Variable", "Label", names(loadings)[!names(loadings) %in% c("Variable", "Label")])]
     loading_cols <- 3:(n + 2)
   } else {
     loading_cols <- 2:(n + 1)
@@ -200,19 +185,16 @@
   attr(loadings, "scores") <- model$scores
   attr(loadings, "additional_arguments") <- list(...)
   attr(loadings, "n") <- n
+  attr(loadings, "threshold") <- threshold
+  attr(loadings, "sort") <- sort
   attr(loadings, "type") <- model$fn
   attr(loadings, "loadings_columns") <- loading_cols
 
   # Sorting
   if (isTRUE(sort)) {
     loadings <- .sort_loadings(loadings)
   }
 
-  # Replace by NA all cells below threshold
-  if (!is.null(threshold)) {
-    loadings <- .filter_loadings(loadings, threshold = threshold)
-  }
-
   # Add some more attributes
   attr(loadings, "loadings_long") <- .long_loadings(loadings, threshold = threshold, loadings_columns = loading_cols)
   # here we match the original columns in the data set with the assigned components
@@ -263,3 +245,26 @@
   class(out) <- c("parameters_omega", class(out))
   out
 }
+
+
+.get_fa_variance_summary <- function(model) {
+  n <- model$factors
+  variance <- as.data.frame(unclass(model$Vaccounted))
+
+  data_summary <- .data_frame(
+    Component = names(variance),
+    Eigenvalues = model$values[1:n],
+    Variance = as.numeric(variance["Proportion Var", ])
+  )
+
+  if ("Cumulative Var" %in% row.names(variance)) {
+    data_summary$Variance_Cumulative <- as.numeric(variance["Cumulative Var", ])
+  } else if (ncol(variance) == 1) {
+    data_summary$Variance_Cumulative <- as.numeric(variance["Proportion Var", ])
+  } else {
+    data_summary$Variance_Cumulative <- NA
+  }
+  data_summary$Variance_Proportion <- data_summary$Variance / sum(data_summary$Variance)
+
+  data_summary
+}