1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
|
#' Reshape loadings between wide/long formats
#'
#' Reshape loadings between wide/long formats.
#'
#'
#' @examples
#' if (require("psych")) {
#' pca <- model_parameters(psych::fa(attitude, nfactors = 3))
#' loadings <- reshape_loadings(pca)
#'
#' loadings
#' reshape_loadings(loadings)
#' }
#' @export
reshape_loadings <- function(x, ...) {
UseMethod("reshape_loadings")
}
#' @rdname reshape_loadings
#' @inheritParams principal_components
#' @export
reshape_loadings.parameters_efa <- function(x, threshold = NULL, ...) {
current_format <- attributes(x)$loadings_format
if (is.null(current_format) || current_format == "wide") {
.long_loadings(x, threshold = threshold)
} else {
.wide_loadings(x)
}
}
#' @rdname reshape_loadings
#' @param loadings_columns Vector indicating the columns corresponding to loadings.
#' @export
reshape_loadings.data.frame <- function(x, threshold = NULL, loadings_columns = NULL, ...) {
if (is.null(loadings_columns)) loadings_columns <- seq_len(ncol(x))
if (length(loadings_columns) > 1) {
.long_loadings(x, threshold = threshold, loadings_columns = loadings_columns)
}
}
#' @keywords internal
.wide_loadings <- function(loadings,
loadings_columns = "Loading",
component_column = "Component",
variable_column = "Variable",
...) {
if (is.numeric(loadings[[component_column]])) {
loadings[[component_column]] <- paste0("F", loadings[[component_column]])
}
complexity_column <- if ("Complexity" %in% colnames(loadings)) "Complexity" else NULL
uniqueness_column <- if ("Uniqueness" %in% colnames(loadings)) "Uniqueness" else NULL
reshape_columns <- c(loadings_columns, component_column, variable_column, complexity_column, uniqueness_column)
loadings <- stats::reshape(
loadings[reshape_columns],
idvar = variable_column,
timevar = component_column,
direction = "wide",
v.names = loadings_columns,
sep = "_"
)
names(loadings) <- gsub(paste0(loadings_columns, "_"), "", names(loadings), fixed = TRUE)
attr(loadings, "loadings_format") <- "wide"
class(loadings) <- unique(c("parameters_loadings", class(loadings)))
# clean-up, column-order
row.names(loadings) <- NULL
column_order <- c(setdiff(colnames(loadings), c("Complexity", "Uniqueness")), c("Complexity", "Uniqueness"))
loadings[column_order[column_order %in% colnames(loadings)]]
}
#' @keywords internal
.long_loadings <- function(loadings, threshold = NULL, loadings_columns = NULL) {
if (is.null(loadings_columns)) {
loadings_columns <- attributes(loadings)$loadings_columns
}
if (!is.null(threshold)) {
loadings <- .filter_loadings(loadings, threshold = threshold, loadings_columns = loadings_columns)
}
# Reshape to long
long <- stats::reshape(loadings,
direction = "long",
varying = list(names(loadings)[loadings_columns]),
v.names = "Loading",
timevar = "Component",
idvar = "Variable"
)
# Restore component names
for (i in 1:insight::n_unique(long$Component)) {
component <- unique(long$Component)[[i]]
name <- names(loadings)[loadings_columns][[i]]
long[long$Component == component, "Component"] <- name
}
# Filtering
long <- long[!is.na(long$Loading), ]
row.names(long) <- NULL
# Reorder columns
loadings <- long[, c(
"Component",
"Variable",
"Loading",
names(loadings)[-loadings_columns][!names(loadings)[-loadings_columns] %in% c("Component", "Variable", "Loading")]
)]
attr(loadings, "loadings_format") <- "long"
class(loadings) <- unique(c("parameters_loadings", class(loadings)))
loadings
}
#' @export
print.parameters_loadings <- function(x, ...) {
formatted_table <- insight::format_table(x)
cat(insight::export_table(formatted_table))
invisible(x)
}
|
