R/lav_efa_print.R

In lavaan: Latent Variable Analysis

# print only (standardized) loadings
print.lavaan.efa <- function(x, nd = 3L, cutoff = 0.3,
                          dot.cutoff = 0.1, alpha.level = 0.01, ...) {
    # unclass
    y <- unclass(x)

    if(!y$header$optim.converged) {
        cat("** WARNING ** Optimizer did not end normally\n")
        cat("** WARNING ** Estimates below are most likely unreliable\n")
    }

    # loadings per block
    for(b in seq_len(y$efa$nblocks)) {
        cat("\n")
        if(length(y$efa$block.label) > 0L) {
            cat(y$efa$block.label[[b]], ":\n\n", sep = "")
        }
        LAMBDA <- unclass(y$efa$lambda[[b]])
        lav_print_loadings(LAMBDA, nd = nd, cutoff = cutoff,
                           dot.cutoff = dot.cutoff,
                           alpha.level = alpha.level,
                           x.se = y$efa$lambda.se[[b]])
        cat("\n")
    }

    invisible(LAMBDA)
}

# print efaList
print.efaList <- function(x, nd = 3L, cutoff = 0.3,
                          dot.cutoff = 0.1, alpha.level = 0.01, ...) {
    # unclass
    y <- unclass(x)

    # kill loadings element if present
    y[["loadings"]] <- NULL

    nfits <- length(y)
    RES <- vector("list", nfits)
    for(ff in seq_len(nfits)) {
        res <-  lav_object_summary(y[[ff]], fit.measures = FALSE,
                                            estimates    = FALSE,
                                            modindices   = FALSE,
                                            efa          = TRUE,
                                            efa.args = list(
                                                lambda           = TRUE,
                                                theta            = FALSE,
                                                psi              = FALSE,
                                                eigenvalues      = FALSE,
                                                sumsq.table      = FALSE,
                                                lambda.structure = FALSE,
                                                fs.determinacy   = FALSE,
                                                se               = FALSE,
                                                zstat            = FALSE,
                                                pvalue           = FALSE))
        RES[[ff]] <- print.lavaan.efa(res, nd = nd, cutoff = cutoff,
                                      dot.cutoff = dot.cutoff,
                                      alpha.level = alpha.level, ...)
    }

    invisible(RES)
}


# print summary efaList
print.efaList.summary <- function(x, nd = 3L, cutoff = 0.3,
                                  dot.cutoff = 0.1, alpha.level = 0.01,
                                  ...) {

    # unclass
    y <- unclass(x)

    # get nd, if it is stored as an attribute
    ND <- attr(y, "nd")
    if(!is.null(ND) && is.numeric(ND)) {
        nd <- as.integer(ND)
    }
    # get cutoff, if it is stored as an attribute
    CT <- attr(y, "cutoff")
    if(!is.null(CT) && is.numeric(CT)) {
        cutoff <- CT
    }
    # get dot.cutoff, if it is stored as an attribute
    DC <- attr(y, "dot.cutoff")
    if(!is.null(DC) && is.numeric(DC)) {
        dot.cutoff <- DC
    }
    # get alpha.level, if it is stored as an attribute
    AL <- attr(y, "alpha.level")
    if(!is.null(AL) && is.numeric(AL)) {
        alpha.level <- AL
    }

    cat("This is ",
        sprintf("lavaan %s", x$lavaan.version),
        " -- running exploratory factor analysis\n", sep = "")

    # everything converged?
    if(!x$converged.flag) {
        cat("lavaan WARNING: not all models did converge!\n")
    }
    cat("\n")


    # estimator
    c1 <- c("Estimator")
    # second column
    tmp.est <- toupper(x$estimator)
    if(tmp.est == "DLS") {
        dls.first.letter <- substr(x$estimator.args$dls.GammaNT,
                                   1L, 1L)
        tmp.est <- paste("DLS-", toupper(dls.first.letter), sep = "")
    }
    c2 <- tmp.est

    # additional estimator args
    if(!is.null(x$estimator.args) &&
       length(x$estimator.args) > 0L) {
        if(x$estimator == "DLS") {
            c1 <- c(c1, "Estimator DLS value for a")
            c2 <- c(c2, x$estimator.args$dls.a)
        }
    }

    # rotation method
    c1 <- c(c1, "Rotation method")
    if(x$rotation == "none") {
        MM <- toupper(x$rotation)
    } else if(x$rotation.args$orthogonal) {
        MM <- paste(toupper(x$rotation), " ", "ORTHOGONAL",
                sep = "")
    } else {
       MM <- paste(toupper(x$rotation), " ", "OBLIQUE",
                    sep = "")
    }
    c2 <- c(c2, MM)

    if(x$rotation != "none") {

        # method options
        if(x$rotation == "geomin") {
            c1 <- c(c1, "Geomin epsilon")
            c2 <- c(c2, x$rotation.args$geomin.epsilon)
        } else if(x$rotation == "orthomax") {
            c1 <- c(c1, "Orthomax gamma")
            c2 <- c(c2, x$rotation.args$orthomax.gamma)
        } else if(x$rotation == "cf") {
            c1 <- c(c1, "Crawford-Ferguson gamma")
            c2 <- c(c2, x$rotation.args$cf.gamma)
        } else if(x$rotation == "oblimin") {
            c1 <- c(c1, "Oblimin gamma")
            c2 <- c(c2, x$rotation.args$oblimin.gamma)
        } else if(x$rotation == "promax") {
            c1 <- c(c1, "Promax kappa")
            c2 <- c(c2, x$rotation.args$promax.kappa)
        }

        # rotation algorithm
        c1 <- c(c1, "Rotation algorithm (rstarts)")
        tmp <- paste(toupper(x$rotation.args$algorithm),
                     " (", x$rotation.args$rstarts, ")", sep = "")
        c2 <- c(c2, tmp)

        # Standardized metric (or not)
       c1 <- c(c1, "Standardized metric")
        if(x$rotation.args$std.ov) {
            c2 <- c(c2, "TRUE")
        } else {
            c2 <- c(c2, "FALSE")
        }

        # Row weights
        c1 <- c(c1, "Row weights")
        tmp.txt <- x$rotation.args$row.weights
        c2 <- c(c2, paste(toupper(substring(tmp.txt, 1, 1)),
                          substring(tmp.txt, 2), sep = ""))
    }

    # format c1/c2
    c1 <- format(c1, width = 33L)
    c2 <- format(c2, width = 18L + max(0, (nd - 3L)) * 4L,
                 justify = "right")

    # create character matrix
    M <- cbind(c1, c2, deparse.level = 0)
    colnames(M) <- rep("",  ncol(M))
    rownames(M) <- rep(" ", nrow(M))

    # print
    write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE)

    # data
    if(!is.null(x$lavdata)) {
        cat("\n")
        lav_data_print_short(x$lavdata, nd = nd)
    }

    # number of models
    nfits <- length(x$model.list)

    # number of factors
    nfactors <- x$nfactors

    # fit measures
    if(!is.null(x$fit.table)) {
        cat("\n")
        if(nfits > 1L) {
            cat("Overview models:\n")
        } else {
            cat("Fit measures:\n")
        }
        print(x$fit.table, nd = nd, shift = 2L)
    }

    # eigenvalues
    if(!is.null(x$model.list[[1]]$efa$eigvals[[1]])) {
        cat("\n")
        if(x$model.list[[1]]$efa$std.ov) {
            cat("Eigenvalues correlation matrix:\n")
        } else {
            cat("Eigenvalues covariance matrix:\n")
        }
        for(b in seq_len(x$model.list[[1]]$efa$nblocks)) {
            cat("\n")
            if(length(x$model.list[[1]]$efa$block.label) > 0L) {
                cat(x$model.list[[1]]$efa$block.label[[b]], ":\n\n", sep = "")
            }
            print(x$model.list[[1]]$efa$eigvals[[b]], nd = nd, shift = 2L)
        } # blocks
    }

    # print summary for each model
    for(f in seq_len(nfits)) {
        res <- x$model.list[[f]]
        attr(res, "nd") <- nd
        attr(res, "cutoff") <- cutoff
        attr(res, "dot.cutoff") <- dot.cutoff
        attr(res, "alpha.level") <- alpha.level

        if(nfits > 1L) {
            if(f == 1L) {
                cat("\n")
            }
            cat("Number of factors: ", nfactors[f], "\n")
        }
        # print.lavaan.summary() prints the $efa element (only) or res
        print(res)
    }

    invisible(y)
}