R/input_manual_process.R

In IPV: Item Pool Visualization

#'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)

}