R/faSort.R

In fungible: Psychometric Functions from the Waller Lab

#' 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 fmat factor loadings (pattern or structure) matrix.
#' @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
#' reflected such that salient loadings are mostly positive.
#' @return 
#'    \item{loadings}{sorted factor loadings matrix.} 
#'    \item{phi}{reflected factor correlation matrix when phi is given as an argument.}
#'    \item{markers}{A list of factor specific markers with loadings >=
#' abs(salient). Markers are sorted by the absolute value of the salient factor
#' loadings.} \item{sortOrder}{sorted row numbers.} 
#'    \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
#' @seealso \code{\link{fals}}
#' @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
#' rownames(Fload) <- paste0("V", 1:nrow(Fload))
#' 
#' cat("\nUnsorted fator loadings\n")
#' print(round( Fload, 2) )
#' 
#' # 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) {
  
  ## Save the original loadings matrix
  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(  
      list(loadings= fmat, 
           phi = phi,
           markers = markers,
           sortOrder = sortOrder,
           SEmat =se)
    )   
  } ## END if Nfac == 1
  
  ## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ##
  ## ---- Sort 2+ Factor Models ####
  ## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ##
  
  # backup of unsorted loadings
  Floadings <- fmat
  
  ## append row numbers to unsorted loadings matrix
  fmat <- cbind(fmat, rowNumbers)
  
  # # locate initial factor assignments 
  # # (max abs loadings for each row)
  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
  
  
  ## Count salient loadings per factor
  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 ####
  
  # Sort loadings so that loadings
  # 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
  ## Start with 0, next loop adds 1 
  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...
    
    # Sort loadings by abs value within factors
    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
          ## Vector is sorted order of items loading on factor i
          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) 
  # Note that due to cross loadings, a variable
  # 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.
  # salient loadings are positive
  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 ####
  
  # Sort markers by |factor loading|
  for (i in 1:Nfac) {
    markers[[i]] <- markers[[i]][sort.list(abs(Floadings[markers[[i]], i]), 
                                           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
  list(loadings  = fmatReturn, 
       phi       = phi,
       markers   = markers,
       sortOrder = sortOrder,
       SEmat     = se)
  
} ## END faSort function