Nothing
#'Input Manual Process
#'
#'Pre-processes the SEM estimates listed using \code{\link{input_manual_simple}}
#'or \code{\link{input_manual_nested}} for the use of chart functions.
#'
#'@param data list generated by \code{\link{input_manual_simple}} or
#' \code{\link{input_manual_nested}} with complete data.
#'
#'@return List containing formatted data including center distances for
#' \code{\link{item_chart}}, \code{\link{facet_chart}}, and
#' \code{\link{nested_chart}}.
#'
#'@seealso \code{\link{input_manual_simple}} \code{\link{input_manual_nested}}
#'
#'@examples
#'# these RSES data can also be seen in self_confidence, the example data of
#'# this package
#'mydata <- input_manual_simple(
#'test_name = "RSES",
#'facet_names = c("Ns", "Ps"),
#'items_per_facet = 5,
#'item_names = c(2, 5, 6, 8, 9,
#' 1, 3, 4, 7, 10),
#'test_loadings = c(.5806, .5907, .6179, .5899, .6559,
#' .6005, .4932, .4476, .5033, .6431),
#'facet_loadings = c(.6484, .6011, .6988, .6426, .6914,
#' .6422, .5835, .536, .5836, .6791),
#'correlation_matrix = matrix(data = c(1, .69,
#' .69, 1),
#' nrow = 2,
#' ncol = 2))
#'mydata
#'input_manual_process(mydata)
#'
#'@export
input_manual_process <- function(data) {
# nested case ----------------------------------------------------------------
if (names(data)[2] == "tests") {
# checking ---------------------------------------------
# missing data
if (any(unlist(lapply(data$tests, is.na)))
) message("Missing data on test. Test treated as having no facets.")
# factor names mismatching
if (!any(is.na(data$tests))) {
x <- lapply(data$tests, `[[`, 1)
x <- sort(as.character(unlist(lapply(x, `[[`, "factor"))))
if (!isTRUE(all.equal(sort(as.character(data$global$fls$subfactor)), x))
) stop ("Factor name or item per factor count mismatch between global
and tests")
}
# item names or number of items mismatching
if (!any(is.na(data$tests))) {
x <- lapply(data$tests, `[[`, 1)
x <- as.character(unlist(lapply(x, `[[`, "item")))
x <- sort(paste(data$global$fls$subfactor, sep = ".", x))
if (!isTRUE(all.equal(sort(as.character(data$global$fls$item)), x))
) stop ("Number of items or item name mismatch between global and
tests")
}
# factor loadings mismatching
if (!any(is.na(data$tests))) {
y <- data$global$fls
y <- y[order(as.character(y$subfactor), y$item),]
x <- do.call(rbind, lapply(data$tests, `[[`, 1))
x <- x[order(as.character(x$factor)),]
x$item <- paste(y$subfactor, sep = ".", x$item)
x <- x[order(as.character(x$factor), x$item),]
y <- y$subfactor_loading
x <- x$factor_loading
if (!isTRUE(all.equal(x, y))
) stop ("Factor loadings inconsistent between global and tests")
}
# processing -------------------------------------------
est <- list()
est$global <- input_manual_process_factor(data$global)
est$tests <- c(
lapply(data$tests[!is.na(data$tests)], input_manual_process_factor),
data$tests[is.na(data$tests)])
mydata <- list(
est = est,
est_raw = data,
xarrow = NA
)
class(mydata) <- c("IPV", "list")
# simple case ----------------------------------------------------------------
} else {
mydata <- ipv_expand(input_manual_process_factor(data), data)
}
# return ---------------------------------------------------------------------
return(mydata)
}
#' Input Manual Process Factor
#'
#' Helper function of \code{\link{input_manual_process}}.
#'
#' @param data list generated by \code{\link{input_manual_simple}} with complete
#' data.
#'
#' @return List containing formatted data including center distances for a
#' single factor.
input_manual_process_factor <- function(data) {
cds <- data.frame(
factor = data$fls$factor,
subfactor = data$fls$subfactor,
item = as.factor(data$fls$item),
cd = data$fls$subfactor_loading ^ 2 / data$fls$factor_loading ^ 2 - 1,
mean_cd = NA)
# negative center distances are adjusted to zero for chart clarity
bad <- min(cds$cd)
bad <- bad < 0
if (bad) message ("Negative center distance adjusted to 0")
cds$cd[cds$cd < 0] <- 0
mean_cds <- lapply(split(cds, cds$subfactor),
function (x) x$mean_cd <- mean(x$cd))
aggregate_cds <- lapply(split(data$fls, data$fls$subfactor), function(x) {
x$aggregate_cd <- max(
sum(x$subfactor_loading ^ 2) / sum(x$factor_loading ^ 2) - 1,
0)
})
cds$mean_cd <- as.numeric(mean_cds[cds$subfactor])
cds$aggregate_cd <- as.numeric(aggregate_cds[cds$subfactor])
mydata <- list(cds = cds,
cors = data$cors)
return(mydata)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.