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 129 130 131 132 133 134 135 136 137 138 139 140 141
|
#' Parameters from Bayesian Exploratory Factor Analysis
#'
#' Format Bayesian Exploratory Factor Analysis objects from the BayesFM package.
#'
#' @param model Bayesian EFA created by the `BayesFM::befa`.
#' @inheritParams principal_components
#' @inheritParams bayestestR::describe_posterior
#' @inheritParams model_parameters.default
#' @param ... Arguments passed to or from other methods.
#'
#' @examples
#' library(parameters)
#' \donttest{
#' if (require("BayesFM")) {
#' efa <- BayesFM::befa(mtcars, iter = 1000)
#' results <- model_parameters(efa, sort = TRUE, verbose = FALSE)
#' results
#' efa_to_cfa(results, verbose = FALSE)
#' }
#' }
#' @return A data frame of loadings.
#' @export
model_parameters.befa <- function(model,
sort = FALSE,
centrality = "median",
dispersion = FALSE,
ci = 0.95,
ci_method = "eti",
test = NULL,
verbose = TRUE,
...) {
if (!attr(model, "post.column.switch") || !attr(model, "post.sign.switch")) {
insight::check_if_installed("BayesFM")
if (!attr(model, "post.column.switch")) model <- BayesFM::post.column.switch(model)
if (!attr(model, "post.sign.switch")) model <- BayesFM::post.sign.switch(model)
}
factor_loadings <- as.data.frame(model$alpha)
names(factor_loadings) <- gsub("alpha:", "", names(factor_loadings), fixed = TRUE)
factor_loadings <- stats::reshape(
factor_loadings,
direction = "long",
varying = list(names(factor_loadings)),
sep = "_",
timevar = "Variable",
v.names = "Loading",
idvar = "Draw",
times = names(factor_loadings)
)
components <- as.data.frame(model$dedic)
names(components) <- gsub("dedic:", "", names(components), fixed = TRUE)
components <- stats::reshape(
components,
direction = "long",
varying = list(names(components)),
sep = "_",
timevar = "Variable",
v.names = "Component",
idvar = "Draw",
times = names(components)
)
factor_loadings <- merge(components, factor_loadings)
# Compute posterior by dedic
long_loadings <- data.frame()
for (var in unique(factor_loadings$Variable)) {
for (comp in unique(factor_loadings$Component)) {
chunk <- factor_loadings[factor_loadings$Variable == var & factor_loadings$Component == comp, ] # nolint
if (nrow(chunk) == 0) {
rez <-
bayestestR::describe_posterior(
factor_loadings$Loading,
centrality = centrality,
dispersion = dispersion,
ci = ci,
ci_method = ci_method,
test = test,
verbose = verbose,
...
)
rez[1, ] <- NA
} else {
rez <-
bayestestR::describe_posterior(
chunk$Loading,
centrality = centrality,
dispersion = dispersion,
ci = ci,
ci_method = ci_method,
test = test,
verbose = verbose,
...
)
}
long_loadings <- rbind(
long_loadings,
cbind(data.frame(Component = comp, Variable = var), rez)
)
}
}
long_loadings$Component <- paste0("F", long_loadings$Component)
# Clean
long_loadings$Parameter <- NULL
if ("CI" %in% names(long_loadings) && insight::n_unique(long_loadings$CI) == 1) {
long_loadings$CI <- NULL
}
long_loadings <- long_loadings[long_loadings$Component != 0, ]
factor_loadings <- .wide_loadings(
long_loadings,
loadings_columns = names(long_loadings)[3],
component_column = "Component",
variable_column = "Variable"
)
# Add attributes
attr(factor_loadings, "model") <- model
attr(factor_loadings, "additional_arguments") <- list(...)
attr(factor_loadings, "n") <- insight::n_unique(long_loadings$Component)
attr(factor_loadings, "loadings_columns") <- names(factor_loadings)[2:ncol(factor_loadings)]
attr(factor_loadings, "ci") <- ci
# Sorting
if (isTRUE(sort)) {
factor_loadings <- .sort_loadings(factor_loadings)
}
# Add some more attributes
long_loadings <- stats::na.omit(long_loadings)
row.names(long_loadings) <- NULL
attr(factor_loadings, "loadings_long") <- long_loadings
# add class-attribute for printing
class(factor_loadings) <- c("parameters_efa", class(factor_loadings))
factor_loadings
}
|