# R/faSort.R In fungible: Psychometric Functions from the Waller Lab

#### Documented in faSort

#' Sort a factor loadings matrix
#'
#' faSort takes an unsorted factor pattern or structure matrix and returns a
#' sorted matrix with (possibly) reflected columns. Sorting is done such that
#' variables that load on a common factor are grouped together for ease of
#' interpretation.
#'
#'
#' @param phi factor correlation matrix. Default = NULL. If reflect = TRUE then
#' phi will be corrected to match the new factor orientations.
#' @param BiFactor (logical) Is the solution a bifactor model?
#' @param salient factor markers with loadings >= abs(salient) will be saved in
#' the markers list. Note that a variable can be a marker of more than one
#' factor.
#' @param reflect (logical) if reflect = TRUE then the factors will be
#' @return
#'    \item{phi}{reflected factor correlation matrix when phi is given as an argument.}
#' abs(salient). Markers are sorted by the absolute value of the salient factor
#'    \item{SEmat}{The SEmat is a
#' so-called Start-End matrix that lists the first (start) and last (end) row
#' for each factor in the sorted pattern matrix.}
#' @author Niels Waller
#' @keywords Statstics
#' @family Factor Analysis Routines
#' @export
#' @examples
#'
#' set.seed(123)
#' F <- matrix( c( .5,  0,
#'                 .6,  0,
#'                  0, .6,
#'                 .6,  0,
#'                  0, .5,
#'                 .7,  0,
#'                  0, .7,
#'                  0, .6), nrow = 8, ncol = 2, byrow=TRUE)
#'
#' Rex1 <- F %*% t(F); diag(Rex1) <- 1
#'
#' Items <- c("1. I am often tense.\n",
#'            "2. I feel anxious much of the time.\n",
#'            "3. I am a naturally curious individual.\n",
#'            "4. I have many fears.\n",
#'            "5. I read many books each year.\n",
#'            "6. My hands perspire easily.\n",
#'            "7. I have many interests.\n",
#'            "8. I enjoy learning new words.\n")
#'
#' exampleOut <- fals(R = Rex1, nfactors = 2)
#'
#' # Varimax rotation
#' Fload <- varimax(exampleOut$loadings)$loadings[]
#'
#' # Add some row labels
#'
#'
#' # Sort items and reflect factors
#' out1 <- faSort(fmat = Fload,
#'                salient = .25,
#'                reflect = TRUE)
#'
#' FloadSorted <- out1$loadings #' #' cat("\nSorted fator loadings\n") #' print(round( FloadSorted, 2) ) #' #' # Print sorted items #' cat("\n Items sorted by Factor\n") #' cat("\n",Items[out1$sortOrder])

faSort <- function(fmat,
phi      = NULL,
BiFactor = FALSE,
salient  = .25,
reflect  = TRUE) {

fmatOriginal <- fmat

## Are we working with a bifactor solution?
if(BiFactor) fmat <- fmat[, -1]

Nfac <- ncol(fmat)
Nrow <- nrow(fmat)
rowNames <- rownames(fmat)
rowNumbers <- 1:Nrow

## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ##
## ---- Sort 1 Factor Models  ####
## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ##

## If single factor model
if (Nfac == 1) {
itemOrder <- sort.list(abs(fmat),
decreasing = TRUE)
fmat <- fmat[itemOrder, 1, drop = FALSE]
dimnames(fmat) <- list(rowNames[itemOrder], "f1")
markers = NULL
sortOrder = itemOrder
se = NULL
return(
phi = phi,
markers = markers,
sortOrder = sortOrder,
SEmat =se)
)
} ## END if Nfac == 1

## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ##
## ---- Sort 2+ Factor Models ####
## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ##

fmat <- cbind(fmat, rowNumbers)

# # locate initial factor assignments
FacAssignments <- apply(abs(fmat[,1:Nfac]), 1, which.max)

## ----____ Group indicators to factors ####

## Vector to count how many salient indicators per factor, start with zero
NumberSalient <- rep(0, Nfac)
names(NumberSalient) <- paste(seq_len(Nfac)) ## Add names

countSalient <- table(FacAssignments)

## Overwrite placeholders in NumberSalient with salient count
NumberSalient[names(countSalient)] <- countSalient

# varsOnFacs is a vector that lists the variables that load
# on each factor

varsOnFacs <- NA
for (i in 1:Nfac) {
varsOnFacs <- c(varsOnFacs, rowNumbers[FacAssignments == i])
} # END for (i in 1:Nfac)

## Drop the initial NA value
varsOnFacs <- varsOnFacs[-1]

#### ----____ Unsorted 'staircase' pattern ####

# on a common factor are grouped together
fmat <- fmat[varsOnFacs, ]

# Generate an Nfac by 2 matrix, se (start/end), that
# lists the (s)tart and (e)nd row numbers
# for each factor

## Find variable number where each factor ends
Frows <- c(0, cumsum(NumberSalient))

# Start/End matrix
se <- matrix(0, nrow = Nfac, ncol = 2)
for (i in 1:Nfac) {
## 1st element: Factor i starts where factor (i - 1) ends, plus one
## 2nd element: Factor i ends in Frow[i] but we appended a zero to Frow
## such that we need to take Frow[i + 1] instead
se[i, ] <- (c(Frows[i] + 1, Frows[i + 1]))
} # END for (i in 1:Nfac)

#### ----____ Sort 'staircase' pattern ####

## Create matrix to update each loop below (i.e., 'if (se[1, 2] != Nrow)')
#fmatUpdated <- fmat
FStaircase <- rep(99, Nfac+1)

## If no general factor found then sort items within factors
if (se[1, 2] != Nrow ) { ## If all items do not load on the first factor...

fmatAbs <- abs(fmat)
for (i in 1:Nfac) {

## If factor has no salient items, do nothing
if (NumberSalient[i] == 0) {
## If a factor has no salient markers, do not sort it
} else {

## For factor i, only sort items with salient markers on that factor
r_order <- Frows[i] + sort.list(fmatAbs[(se[i, 1]:se[i, 2]), i],
decreasing = TRUE)

## **** Build F staircase ****
FStaircase <- rbind(FStaircase,fmat[r_order, , drop=FALSE ] )

} # END if (NumberSalient[i] == 0)

} # END for (i in 1:Nfac)
} # END  if (se[1,2] != Nrow )

fmat <- FStaircase[-1, ] # delete row of 99's

#### ----____ Create sortOrder object ####

# sortOrder gives the sort order of the
# original variables
## CG EDITS (13 sept 19): Nfac + 1 is "rowNumbers"
sortOrder <- fmat[, Nfac + 1]

## Drop rowNumbers column from fmat, no longer needed
fmat <- fmat[, -(Nfac + 1)]

#### ----____ Create markers object ####

# find factor markers (variables that load
# above a user-defined salient threhold)
# can be a marker of more than one factor
markers <- as.list(rep(NA, Nfac))
for (iMark in 1:Nfac) {
markers[[iMark]] <- sortOrder[ abs(fmat[, iMark]) >= salient ]
} # END for (iMark in 1:Nfac)

#### ----____ Reflect factors ####

# If reflect = TRUE then reflect factors s.t.
if (reflect == TRUE) {
## Determine whether factors are negatively oriented
Dsgn <- diag(sign(colSums(fmat^3)))
## If factors negatively oriented, multiply by -1, else multiply by 1
fmat <- fmat %*% Dsgn
if (!is.null(phi)) {
## If factor is negative, reverse corresponding factor correlations
phi <- Dsgn %*% phi %*% Dsgn
} # END if (!is.null(phi))
} # END if (reflect == TRUE)

#### ----____ Sort 'markers' object ####

for (i in 1:Nfac) {
decreasing = TRUE)]
} # END for (i in 1:Nfac)

#### ----____ Name the output objects ####

## CG EDITS (13 sept 19): Add names to list of factor markers
names(markers) <- paste("Factor", 1:Nfac, "markers")

## Add dimension names to the Start/End matrix
rownames(se) <- paste0("f", 1:Nfac)
colnames(se) <-c("Start", "End")

if (!BiFactor) {
fmatReturn <- fmat
} # END if (!BiFactor)

if (BiFactor) {
fmatReturn <- cbind(fmatOriginal[sortOrder, 1], fmat)
} # END if (BiFactor)

## Return list of output