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
|
#' @export
model_parameters.PCA <- function(model,
sort = FALSE,
threshold = NULL,
labels = NULL,
verbose = TRUE,
...) {
loadings <- as.data.frame(model$var$coord)
n <- model$call$ncp
# Get summary
eig <- as.data.frame(model$eig[1:n, ])
data_summary <- .data_frame(
Component = names(loadings),
Eigenvalues = eig$eigenvalue,
Variance = eig$`percentage of variance` / 100,
Variance_Cumulative = eig$`cumulative percentage of variance` / 100
)
data_summary$Variance_Proportion <- data_summary$Variance / sum(data_summary$Variance)
# 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)
}
loadings$Complexity <- (apply(loadings[, loading_cols, drop = FALSE], 1, function(x) sum(x^2)))^2 / apply(loadings[, loading_cols, drop = FALSE], 1, function(x) sum(x^4))
# Add attributes
attr(loadings, "summary") <- data_summary
attr(loadings, "model") <- model
attr(loadings, "rotation") <- "none"
attr(loadings, "scores") <- as.data.frame(model$ind$coord)
attr(loadings, "additional_arguments") <- list(...)
attr(loadings, "n") <- n
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)
# add class-attribute for printing
if (inherits(model, "PCA")) {
attr(loadings, "type") <- "pca"
class(loadings) <- unique(c("parameters_pca", "see_parameters_pca", class(loadings)))
} else if (inherits(model, "FAMD")) {
attr(loadings, "type") <- "fa"
class(loadings) <- unique(c("parameters_efa", "see_parameters_efa", class(loadings)))
}
loadings
}
#' @export
model_parameters.FAMD <- model_parameters.PCA
|
