R/lav_data_print.R

In lavaan: Latent Variable Analysis

# print object from lavData class
#

setMethod("show", "lavData",
function(object) {
    # print 'lavData' object
    res <- lav_data_summary_short(object)
    lav_data_print_short(res, nd = 3L)
})

# create summary information for @lavdata slot
lav_data_summary_short <- function(object) {

    # which object?
    if(inherits(object, "lavaan")) {
        lavdata <- object@Data
    } else if(inherits(object, "lavData")) {
        lavdata <- object
    } else {
        stop("lavaan ERROR: object must be lavaan or lavData object")
    }

    # two or three columns (depends on nobs/norig)
    threecolumn <- FALSE
    for(g in 1:lavdata@ngroups) {
        if(lavdata@nobs[[g]] != lavdata@norig[[g]]) {
            threecolumn <- TRUE
            break
        }
    }

    # clustered data?
    clustered <- FALSE
    if( .hasSlot(lavdata, "cluster") && # in case we have an old obj
        length(lavdata@cluster) > 0L ) {
        clustered <- TRUE
    }

    # multilevel data?
    multilevel <- FALSE
    if( .hasSlot(lavdata, "nlevels") && # in case we have an old obj
        lavdata@nlevels > 1L ) {
        multilevel <- TRUE
    }

    # extract summary information
    datasummary <- list(ngroups  = lavdata@ngroups,
                        nobs     = unlist(lavdata@nobs))

    # norig?
    if(threecolumn) {
        datasummary$norig <- unlist(lavdata@norig)
    }

    # multiple groups?
    if(lavdata@ngroups > 1L) {
        datasummary$group.label <- lavdata@group.label
    }

    # sampling weights?
    if( (.hasSlot(lavdata, "weights")) && # in case we have an old object
        (!is.null(lavdata@weights[[1L]])) ) {
        datasummary$sampling.weights <- lavdata@sampling.weights
    }

    # clustered/multilevel data?
    if(clustered) {
        if(multilevel) {
            datasummary$nlevels   <- lavdata@nlevels
        }
        datasummary$cluster   <- lavdata@cluster

        if(lavdata@ngroups == 1L) {
            datasummary$nclusters <- unlist(lavdata@Lp[[1]]$nclusters)
        } else {
            tmp <- vector("list", length = lavdata@ngroups)
            for(g in seq_len(lavdata@ngroups)) {
                tmp[[g]] <- unlist(lavdata@Lp[[g]]$nclusters)
            }
            datasummary$nclusters <- tmp
        }
    }

    # missing data?
    if(!is.null(lavdata@Mp[[1L]])) {
        datasummary$npatterns <- sapply(lavdata@Mp, "[[", "npatterns")
        if(multilevel && !is.null(lavdata@Mp[[1L]]$Zp)) {
            datasummary$npatterns2 <- sapply(lapply(lavdata@Mp,
                                            "[[", "Zp"), "[[", "npatterns")
        }
    }

    datasummary
}

lav_data_print_short <- function(object, nd = 3L) {

    # object should data summary
    if(inherits(object, "lavaan")) {
        object <- lav_data_summary_short(object)
    }
    datasummary <- object

    num.format  <- paste("%", max(8L, nd + 5L), ".", nd, "f", sep = "")

    # threecolumn
    threecolumn <- !is.null(datasummary$norig)

    # multilevel?
    multilevel <- !is.null(datasummary$nlevels)

    # clustered?
    clustered <- !is.null(datasummary$cluster) && is.null(datasummary$nlevels)

    # header? no, for historical reasons only
    #cat("Data information:\n\n")

    c1 <- c2 <- c3 <- character(0L)

    # number of observations
    if(datasummary$ngroups == 1L) {
        if(threecolumn) {
            c1 <- c(c1, ""); c2 <- c(c2, "Used"); c3 <- c(c3, "Total")
        }
        c1 <- c(c1, "Number of observations")
        c2 <- c(c2, datasummary$nobs)
        c3 <- c(c3, ifelse(threecolumn, datasummary$norig, ""))
    } else {
        c1 <- c(c1, "Number of observations per group:");
        if(threecolumn) {
            c2 <- c(c2, "Used"); c3 <- c(c3, "Total")
        } else {
            c2 <- c(c2, ""); c3 <- c(c3, "")
        }
        for(g in 1:datasummary$ngroups) {
            c1 <- c(c1, sprintf("  %-40s", datasummary$group.label[g]))
            c2 <- c(c2, datasummary$nobs[g])
            c3 <- c(c3, ifelse(threecolumn, datasummary$norig[g], ""))
        } # g
    }

    # number of clusters
    if(datasummary$ngroups == 1L) {
        if(multilevel) {
            for(l in 2:datasummary$nlevels) {
                c1 <- c(c1,
                        paste("Number of clusters [",
                              datasummary$cluster[l-1], "]", sep = ""))
                c2 <- c(c2, datasummary$nclusters[l])
                c3 <- c(c3, "")
            }
        } else if(clustered) {
            c1 <- c(c1, paste("Number of clusters [", datasummary$cluster, "]",
                              sep = ""))
            c2 <- c(c2, datasummary$nclusters[2])
            c3 <- c(c3, "")
        }
    } else {
        if(multilevel) {
            for(l in 2:datasummary$nlevels) {
                c1 <- c(c1,
                  paste("Number of clusters [", datasummary$cluster[l-1], "]:",
                        sep = ""))
                c2 <- c(c2, ""); c3 <- c(c3, "")
                for(g in 1:datasummary$ngroups) {
                    c1 <- c(c1, sprintf("  %-40s", datasummary$group.label[g]))
                    c2 <- c(c2, datasummary$nclusters[[g]][l])
                    c3 <- c(c3, "")
                }
            }
        } else if(clustered) {
            c1 <- c(c1,
             paste("Number of clusters [", datasummary$cluster, "]:", sep = ""))
            c2 <- c(c2, ""); c3 <- c(c3, "")
            for(g in 1:datasummary$ngroups) {
                c1 <- c(c1, sprintf("  %-40s", datasummary$group.label[g]))
                c2 <- c(c2, datasummary$nclusters[[g]][2])
                c3 <- c(c3, "")
            }
        }
    }

    # missing patterns?
    if(!is.null(datasummary$npatterns)) {
        if(datasummary$ngroups == 1L) {
            if(multilevel) {
                c1 <- c(c1, "Number of missing patterns -- level 1")
                c2 <- c(c2, datasummary$npatterns)
                c3 <- c(c3, "")
                if(!is.null(datasummary$npatterns2)) {
                    c1 <- c(c1, "Number of missing patterns -- level 2")
                    c2 <- c(c2, datasummary$npatterns2)
                    c3 <- c(c3, "")
                }
            } else {
                c1 <- c(c1, "Number of missing patterns")
                c2 <- c(c2, datasummary$npatterns)
                c3 <- c(c3, "")
            }
        } else {
            if(multilevel) {
                c1 <- c(c1, "Number of missing patterns per group:")
                c2 <- c(c2, ""); c3 <- c(c3, "")
                for(g in 1:datasummary$ngroups) {
                    c1 <- c(c1,
                            paste(sprintf("  %-40s",
                                  datasummary$group.label[g]), "-- level 1"))
                    c2 <- c(c2, datasummary$npatterns[g])
                    c3 <- c(c3, "")
                    if(!is.null(datasummary$npatterns2)) {
                        c1 <- c(c1,
                            paste(sprintf("  %-40s",
                                  datasummary$group.label[g]), "-- level 2"))
                        c2 <- c(c2, datasummary$npatterns2[g])
                        c3 <- c(c3, "")
                    }
                }
            } else {
                c1 <- c(c1, "Number of missing patterns per group:")
                c2 <- c(c2, ""); c3 <- c(c3, "")
                for(g in 1:datasummary$ngroups) {
                    c1 <- c(c1, sprintf("  %-40s", datasummary$group.label[g]))
                    c2 <- c(c2, datasummary$npatterns[g])
                    c3 <- c(c3, "")
                }
            }
        }
    }

    # sampling weights?
    if(!is.null(datasummary$sampling.weights)) {
        c1 <- c(c1, "Sampling weights variable")
        c2 <- c(c2, datasummary$sampling.weights)
        c3 <- c(c3, "")
    }

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

    # create character matrix
    if(threecolumn) {
        M <- cbind(c1, c2, c3, deparse.level = 0)
    } else {
        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)

    invisible(M)
}