`r params$report.title`"
In kfa: K-Fold Cross Validation for Factor Analysis

knitr::opts_chunk$set(echo = FALSE)
flextable::set_flextable_defaults(fonts_ignore = TRUE)

date: "r format(Sys.Date(), '%B %d, %Y')" params: models: NA report.title: NA index: NA load.flag: .30 cor.flag: .90 rel.flag: .60 digits: 2 width: NA title: "r params$report.title"

cfas <- params$models$cfas
  ## analysis summary info
  k <- length(cfas) # number of folds
  m <- max(unlist(lapply(cfas, length))) # number of models per fold (includes both efa AND custom structures); m == length(mnames)
  mnames <- params$models$model.names # model names
  fac.allow <- length(params$models$efa.structures)
  fac.max <- max(as.numeric(substring(mnames[grepl("-factor", mnames)], 1, 1)))  # kfa naming convention "#-factor"; custom functions are assumed to have different convention
  vnames <- dimnames(lavaan::lavInspect(cfas[[1]][[1]], "sampstat")$cov)[[1]] # variable names
  nvars <- length(vnames)
  nobs <- sum(unlist(lapply(cfas, function(x) lavaan::lavInspect(x[[1]], "nobs"))))
  opts <- lavaan::lavInspect(cfas[[1]][[1]], "options") # estimation options; assumed to be the same for all models

  #### Model Fit ####
  ## summarizing fit statistics by fold
  kfits <- k_model_fit(params$models, index = params$index, by.fold = TRUE) # dataframe for each fold
  fit.table <- agg_model_fit(kfits, index = "all", digits = 2)
  # adjust model order to match model.names and other output
  fit.table <- fit.table[order(factor(fit.table$model, levels = mnames)),]

  ## creating appendix -  folds x model table of fit statistics
  mfits <- k_model_fit(params$models, index = params$index, by.fold = FALSE)
  appendix <- kfa:::get_appendix(mfits, index = "all")

  #### Parameters ####
  ## model structures
  kstructures <- model_structure(params$models)

  ## loadings
  klambdas <- agg_loadings(params$models, flag = params$load.flag, digits = params$digits)

  ## factor correlations
  kcorrs <- agg_cors(params$models, flag = params$cor.flag)

  ## score reliabilities
  krels <- agg_rels(params$models, flag = params$rel.flag, digits = params$digits)

  ## flagged problems
  flagged <- kfa:::model_flags(params$models, kstructures, klambdas, kcorrs, krels)


plot.settings <- list(what = "std", whatLabels = "no", layout = "tree",
                        intercepts = FALSE, residuals = FALSE, thresholds = FALSE,
                        fade = FALSE, posCol = c("#000000"), # "#BF0000"), cut = load.flag, # can update to more nuanced coloring of plots
                        # edge.color = , # could create custom function to utilize this argument
                        weighted = TRUE, negDashed = TRUE, esize = 5,
                        manifests = vnames, reorder = FALSE)
border <- officer::fp_border(width = 2) # manual horizontal flextable border width

Overview

# of folds: r k

# of variables: r nvars

# of observations: r nobs

Maximum # of factors:

Allowed - r fac.allow
Extracted - r fac.max

Estimation: r opts$estimator

Missing Data: r opts$missing

\newpage

Model Summary

Fit across folds by factor model

ftn <- names(fit.table)
df <- ftn[grepl("df", ftn)] # naive or scaled?
index <- unique(gsub("mean.|range.", "", ftn[!ftn %in% c("model", df)]))
fit.map <- data.frame(col_keys = ftn,
                      top = c("model", df, rep(index, each = 2)),
                      bottom = c("model", df, rep(c("mean", "range"), times = length(index))))

fit.flex <- flextable::flextable(fit.table)
fit.flex <- flextable::colformat_double(fit.flex, j = -c(1,2), digits = params$digits)
fit.flex <- kfa:::two_level_flex(fit.flex, mapping = fit.map, vert.cols = c("model", df), border = border)
knitr::knit_print(fit.flex)

Count of folds out of r k with flagged problems

flagged.flex <- kfa:::flextab_format(flagged, bold.type = "none", width = params$width, digits = params$digits)
flagged.flex <- flextable::vline(flagged.flex, j = 2, border = border)
knitr::knit_print(flagged.flex)

Notes:
'mode structure' is the number of folds the EFA identified the mode (most common) structure. This structure was then used in the CFA. 'mode structure' will be r k when the same structure was identified in every fold and < r k when multiple factor structures were identified. The value in 'mode structure' is the maximum value for all remaining columns. See Appendix for all structures.
'improper solution' is the number of folds with non-convergence or a non-positive definite matrix.
'high factor correlation' threshold set to r params$cor.flag.
'low scale reliability' threshold set to r params$rel.flag with $\omega_h$.
'low loading' threshold set to r params$load.flag.
blanks = not applicable

\newpage

Model Details

if(lavaan::lavInspect(params$models$cfas[[1]][[1]], "categorical")){
  what <- "omega_h"
  times <- 1
  j <- 2

} else {
  what <- c("omega_h", "alpha")
  times <- 2
  j <- c(2, 5)
}

rel.map <- data.frame(col_keys = names(krels$reliabilities[[1]]),
                      top = c("factor", rep(what, each = 3)),
                      bottom = c("factor", rep(c("mean", "range", "flag"), times = times)))

for(n in 1:m){
  cat("##", mnames[[n]])
  cat("\n\n")
  cat("**Factor Structure**")
  cat("\n\n")
  cat(gsub("\\*", "\\\\*", gsub("\n", "\n\n", kstructures[kstructures$model == mnames[[n]],]$structure)))
  cat("\n\n")
  ## find fold with lavaan object for the model
  for(f in 1:k){
  if(mnames[[n]] %in% names(params$models$cfas[[f]])) break  
}
    suppressWarnings(do.call(semPlot::semPaths, args = c(list(object = params$models$cfas[[f]][[mnames[[n]]]],
                                           color = list(lat = palette.colors(n = n + 1, palette = "Okabe-Ito",
                                                        recycle = TRUE)[-1]),
                                           title = FALSE),
                                      plot.settings)))
  cat("\n\n")
  cat("**Standardized Loading Across Folds**")
  cat("\n\n")
  if(ncol(klambdas$loadings[[n]]) == 8){

      load.map <- data.frame(col_keys = names(klambdas$loadings[[n]]),
                      top = c("variable", rep("primary factor", 3), "heywood flag", rep("secondary factor", 3)),
                      bottom = c("variable", c("mean", "range", "loading flag", "heywood flag", "mean", "range", "loading flag")))
      lambda.flex <- flextable::flextable(klambdas$loadings[[n]])
      lambda.flex <- flextable::colformat_double(lambda.flex,
                                                 j = which(unlist(lapply(klambdas$loadings[[n]], is.numeric))),
                                                 digits = params$digits)
      lambda.flex <- flextable::align(lambda.flex, i = NULL, j = 1, align = "left", part = "body")
      lambda.flex <- kfa:::two_level_flex(lambda.flex, mapping = load.map,
                                    vert.cols = c("variable", "heywood flag"), border = border)

  } else{
      lambda.flex <- kfa:::flextab_format(klambdas$loadings[[n]], bold.type = "none", digits = params$digits)
      lambda.flex <- flextable::align(lambda.flex, i = NULL, j = 1, align = "left", part = "body")
  }
  cat(knitr::knit_print(lambda.flex))
  cat("Note: loadings flagged when <", params$load.flag, "in a fold. 'heywood flag' is the number of folds the variable's estimated residual variance was negative")
  cat("\n\n")
  if(n > 1){
  cat("**Mean Factor Correlations**")
  cat("\n\n")
  corr.flex <- kfa:::flextab_format(kcorrs$correlations[[n]], bold.type = "none", digits = params$digits)
  corr.flex <- flextable::compose(corr.flex, i = 1, j = 1, value = flextable::as_paragraph(""), part = "header")
  corr.flex <- flextable::vline(corr.flex, j = ncol(kcorrs$correlations[[n]]) - 1, border = border)
  cat(knitr::knit_print(corr.flex))
  cat("Note: 'flag' is the number of folds the factor had a correlation >", params$cor.flag)
  cat("\n\n")
  }
  cat("**Scale Reliability Across Folds**")
  cat("\n\n")
  rel.flex <- flextable::flextable(krels$reliabilities[[n]])
  rel.flex <- flextable::colformat_double(rel.flex, j = j, digits = params$digits)
  rel.flex <- kfa:::two_level_flex(rel.flex, mapping = rel.map, vert.cols = c("factor"), border = border)
  cat(knitr::knit_print(rel.flex))
  cat("Note: 'flag' is the number of folds the scale had a reliability <", params$rel.flag)
  cat("\n\n")
}

\newpage

Appendix

Within Fold Model Fit

index <- names(appendix)[!names(appendix) %in% "fold"]
index <- unique(sub(".[^.]*$", "", index))

ax <- length(index)*length(mnames)
if(ax <= 16){ # is the appendix a reasonable width?

  appendix.map <- data.frame(col_keys = names(appendix),
                      top = c("fold", rep(mnames, each = length(index))),
                      bottom = c("fold", rep(index, times = length(mnames))))

appendix.flex <- kfa:::appendix_wrapper(appendix, appendix.map, border, params$digits)
appendix.flex


} else { # If not, split into two tables 

modsplit <- floor(16/length(index))
colsplit <- 1+length(index)*modsplit
appendix1 <- appendix[1:colsplit]
appendix2 <- appendix[c(1, (colsplit+1):length(appendix))]

appendix1.map <- data.frame(col_keys = names(appendix1),
                           top = c("fold", rep(mnames[1:modsplit], each = length(index))),
                           bottom = c("fold", rep(index, times = modsplit)))

appendix1.flex <- kfa:::appendix_wrapper(appendix1, appendix1.map, border, params$digits)
appendix1.flex
# part 2 needs to be in a separate chunk for some reason
}

if(ax > 16){ 
  appendix2.map <- data.frame(col_keys = names(appendix2),
                            top = c("fold", rep(mnames[(modsplit+1):length(mnames)], each = length(index))),
                            bottom = c("fold", rep(index, times = length(mnames) - modsplit)))
  appendix2.flex <- kfa:::appendix_wrapper(appendix2, appendix2.map, border, params$digits)
  appendix2.flex
}

All EFA Structures

strux <- params$models$efa.structures
for(n in 1:length(strux)){
  cat("### Factors:", n)
  cat("\n\n")
  for(s in seq_along(strux[[n]])){
    cat("**Factor Structure Option", s, "**")
    cat("\n\n")
    cat("**In Folds:", paste(strux[[n]][[s]]$folds, collapse = ", "), "**")
    cat("\n\n")
    if (strux[[n]][[s]]$structure == "") cat("Structure contained single item factor") else cat(gsub("\n", "\n\n", strux[[n]][[s]]$structure))
    cat("\n\n")
  }
}