Nothing
"Promax" <-
function (x,m=4, normalize=FALSE, pro.m = 4)
{
if(missing(m)) m <- pro.m
if(!is.matrix(x) & !is.data.frame(x) ) {
if(!is.null(x$loadings)) x <- as.matrix(x$loadings)
} else {x <- x}
if (ncol(x) < 2)
return(x)
dn <- dimnames(x)
xx <- stats::varimax(x)
x <- xx$loadings
Q <- x * abs(x)^(m - 1)
U <- lm.fit(x, Q)$coefficients
d <- try(diag(solve(t(U) %*% U)),silent=TRUE)
if(inherits(d,"try-error")) {warning("Factors are exactly uncorrelated and the model produces a singular matrix. An approximation is used")
ev <- eigen(t(U) %*% U)
ev$values[ev$values < .Machine$double.eps] <- 100 * .Machine$double.eps
UU <- ev$vectors %*% diag(ev$values) %*% t(ev$vectors)
diag(UU) <- 1
d <- diag(solve(UU))}
U <- U %*% diag(sqrt(d))
dimnames(U) <- NULL
z <- x %*% U
U <- xx$rotmat %*% U
ui <- solve(U)
Phi <- ui %*% t(ui)
dimnames(z) <- dn
class(z) <- "loadings"
result <- list(loadings = z, rotmat = U,Phi = Phi)
class(result) <- c("psych","fa")
return(result)
}
#obviously a direct copy of the promax function, with the addition of returning the angles between factors
#based upon a suggestion to the R-help news group by Ulrich Keller and John Fox.
#added May 31st following suggestions to R-Help by Gunter Nickel
"equamax" <- function(L, Tmat=diag(ncol(L)), eps=1e-5, maxit=1000) { #added kappa in the call to cfT May 3, 2020
kappa=ncol(L)/(2*nrow(L))
if(requireNamespace('GPArotation')) {GPArotation::cfT(L, Tmat=diag(ncol(L)),kappa=kappa, eps=eps, maxit=maxit)} else {stop("biquartimin requires GPArotation")}}
#based completely on the GPArotation GPForth function
#modified to call the varimin function which is derived from the varimax function
varimin <- function(L, Tmat = diag(ncol(L)), normalize = FALSE, eps = 1e-05,
maxit = 1000) {
if(requireNamespace('GPArotation')) {GPArotation::GPForth(A=L,Tmat = diag(ncol(L)), normalize = normalize, eps = eps,
maxit = maxit, method = "varimin") } else {stop("biquartimin requires GPArotation")}}
vgQ.varimin <-
function (L)
{
QL <- sweep(L^2, 2, colMeans(L^2), "-")
list(Gq = L * QL, f = sqrt(sum(diag(crossprod(QL))))^2/4,
Method = "varimin")
}
specialT <- specialQ <- function(L, Tmat = diag(ncol(L)), normalize = FALSE, eps = 1e-05,
maxit = 1000) {
write("A dummy function that can be replaced with either an orthogonal (specialT) or oblique (specialQ) call. You will need to supply it")
list(NA)
}
#a general function to call a number of different rotation functions
#meant to simplify code in fa, principal, faBy, but perhaps not ready for prime time
#not yet included in the public package
"faRotate" <-
function(loadings,rotate="oblimin",...) {
if((class(loadings)[1] == "psych") & is.list(loadings)) loadings <- loadings$loadings
if (rotate=="varimax" |rotate=="Varimax" | rotate=="quartimax" | rotate =="bentlerT" | rotate =="geominT" | rotate =="targetT" | rotate =="bifactor" | rotate =="TargetT"|
rotate =="equamax"| rotate =="varimin"|rotate =="specialT" | rotate =="Promax" | rotate =="promax"| rotate =="cluster" |rotate == "biquartimin" |rotate == "TargetQ" |rotate =="specialQ" ) {
Phi <- NULL
switch(rotate, #The orthogonal cases for GPArotation + ones developed for psych
varimax = {rotated <- stats::varimax(loadings) #varimax is from stats, the others are from GPArotation
loadings <- rotated$loadings},
Varimax = {if (!requireNamespace('GPArotation')) {stop("I am sorry, to do this rotation requires the GPArotation package to be installed")}
#varimax is from the stats package, Varimax is from GPArotations
#rotated <- do.call(rotate,list(loadings,...))
#rotated <- do.call(getFromNamespace(rotate,'GPArotation'),list(loadings,...))
rotated <- GPArotation::Varimax(loadings)
loadings <- rotated$loadings} ,
quartimax = {if (!requireNamespace('GPArotation')) {stop("I am sorry, to do this rotation requires the GPArotation package to be installed")}
#rotated <- do.call(rotate,list(loadings))
rotated <- GPArotation::quartimax(loadings)
loadings <- rotated$loadings} ,
bentlerT = {if (!requireNamespace('GPArotation')) {stop("I am sorry, to do this rotation requires the GPArotation package to be installed")}
#rotated <- do.call(rotate,list(loadings,...))
rotated <- GPArotation::bentlerT(loadings)
loadings <- rotated$loadings} ,
geominT = {if (!requireNamespace('GPArotation')) {stop("I am sorry, to do this rotation requires the GPArotation package to be installed")}
#rotated <- do.call(rotate,list(loadings,...))
rotated <- GPArotation::geominT(loadings)
loadings <- rotated$loadings} ,
targetT = {if (!requireNamespace('GPArotation')) {stop("I am sorry, to do this rotation requires the GPArotation package to be installed")}
#rotated <- do.call(rotate,list(loadings,...))
rotated <- GPArotation::targetT(loadings)
loadings <- rotated$loadings} ,
bifactor = {loadings <- bifactor(loadings)$loadings}, #the next four solutions were not properly returning the values
TargetT = {loadings <- TargetT(loadings,...)$loadings},
equamax = {loadings <- equamax(loadings)$loadings},
varimin = {loadings <- varimin(loadings)$loadings},
specialT = {loadings <- specialT(loadings)$loadings},
Promax = {pro <- Promax(loadings)
loadings <- pro$loadings
Phi <- pro$Phi },
promax = {pro <- Promax(loadings)
loadings <- pro$loadings
Phi <- pro$Phi },
cluster = {loadings <- varimax(loadings)$loadings
pro <- target.rot(loadings)
loadings <- pro$loadings
Phi <- pro$Phi},
biquartimin = {ob <- biquartimin(loadings,)
loadings <- ob$loadings
Phi <- ob$Phi},
TargetQ = {ob <- TargetQ(loadings,...)
loadings <- ob$loadings
Phi <- ob$Phi},
specialQ = {ob <- specialQ(loadings,...)
loadings <- ob$loadings
Phi <- ob$Phi})
} else {
#The following oblique cases all use GPArotation
if (rotate =="oblimin"| rotate=="quartimin" | rotate== "simplimax" | rotate =="geominQ" | rotate =="bentlerQ" |rotate == "targetQ" ) {
if (!requireNamespace('GPArotation')) {warning("I am sorry, to do these rotations requires the GPArotation package to be installed")
Phi <- NULL} else {
ob <- try(do.call(getFromNamespace(rotate,'GPArotation'),list(loadings,...)))
if(inherits(ob,as.character("try-error"))) {warning("The requested transformaton failed, Promax was used instead as an oblique transformation")
ob <- Promax(loadings)}
loadings <- ob$loadings
Phi <- ob$Phi}
} else {message("Specified rotation not found, rotate='none' used")}
}
result <- list(loadings=loadings,Phi=Phi)
class(result) <- c("psych","fa")
return(result)
}
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.