R/lav_partable_full.R

In lavaan: Latent Variable Analysis

# create `full' parameter table, containing (almost) all parameters
# that could be free
#
# main motivation: univariate scores tests (modification indices)
#
lav_partable_full <- function(partable = NULL,
                              lavpta = NULL,
                              strict.exo = FALSE,
                              free = FALSE, start = FALSE) {

    # check minimum requirements: lhs, op, rhs
    stopifnot( !is.null(partable$lhs),
               !is.null(partable$op),
               !is.null(partable$rhs) )

    # lavpta?
    if(is.null(lavpta)) {
        lavpta <- lav_partable_attributes(partable)
    }

    # meanstructure
    if(!is.null(lavpta$meanstructure)) {
        meanstructure <- lavpta$meanstructure
    } else {
        # old object
        meanstructure <- any(partable$op == "~1")
    }

    # number of blocks
    nblocks <- lavpta$nblocks
    ngroups <- lavpta$ngroups
    nlevels <- lavpta$nlevels

    lhs <- rhs <- op <- character(0L)
    block <- group <- level <- integer(0L)

    # new in 0.6-3:
    GROUP.values <- lav_partable_group_values(partable)
    LEVEL.values <- lav_partable_level_values(partable)
    if(is.character(GROUP.values[1])) {
        group <- character(0L)
    }
    if(is.character(LEVEL.values[1L])) {
        level <- character(0L)
    }

    # block number
    b <- 0L
    for(g in 1:ngroups) {
        for(l in 1:nlevels) {

            # block
            b <- b + 1L

            ov.names     <- lavpta$vnames$ov[[b]]
            ov.names.nox <- lavpta$vnames$ov.nox[[b]]
            ov.names.x   <- lavpta$vnames$ov.x[[b]]
            ov.names.ind <- lavpta$vnames$ov.ind[[b]]
            ov.names.ord <- lavpta$vnames$ov.ord[[b]]

            lv.names     <- lavpta$vnames$lv[[b]]

            # eqs.y, eqs.x
            eqs.names <- unique( c(lavpta$vnames$eqs.y[[b]],
                                   lavpta$vnames$eqs.x[[b]]) )
            if(length(eqs.names) > 0L) {
                eqs.y <- eqs.names
                if(strict.exo) {
                    x.idx <- which(eqs.names %in% ov.names.x)
                    if(length(x.idx) > 0L) {
                        eqs.y <- eqs.names[-x.idx]
                    }
                }
                eqs.x <- eqs.names
            } else {
                eqs.y <- character(0L)
                eqs.x <- character(0L)
            }

            # 1 "=~"
            l.lhs <- rep(lv.names, each = length(ov.names.nox))
            l.rhs <- rep(ov.names.nox, times = length(lv.names))

            # remove factor ~ eqs.y combinations, if any
            # because they also appear as a regression
            bad.idx <- which( l.lhs %in% lv.names &
                              l.rhs %in% eqs.y)
            if(length(bad.idx) > 0L) {
                l.lhs <- l.lhs[-bad.idx]
                l.rhs <- l.rhs[-bad.idx]
            }
            l.op  <- rep("=~", length(l.lhs))

            # 2a. "~~" ov ## FIXME: ov.names.nox or ov.names??
            #if(strict.exo) {
                OV <- ov.names.nox
            #} else {
            #    OV <- ov.names
            #}
            nx <- length(OV)
            idx <- lower.tri(matrix(0, nx, nx), diag = TRUE)
            ov.lhs <- rep(OV,  each = nx)[idx] # fill upper.tri
            ov.rhs <- rep(OV, times = nx)[idx]
            ov.op  <- rep("~~", length(ov.lhs))

            # remove dummy indicators that correlate with 'proper'
            # indicators; new in 0.6-14; fixed in 0.6-16
            ov.other <- ov.names[!ov.names %in% c(ov.names.ind, ov.names.x,
                                                  eqs.x, eqs.y)]
            if(length(ov.other) > 0L) {
                bad.idx <- which( (ov.lhs %in% ov.names &
                                   ov.rhs %in% ov.other) |
                                  (ov.lhs %in% ov.other &
                                   ov.rhs %in% ov.names) )
                if(length(bad.idx) > 0L) {
                    ov.lhs <- ov.lhs[-bad.idx]
                    ov.rhs <- ov.rhs[-bad.idx]
                    ov.op  <- ov.op[ -bad.idx]
                }
            }

            # exo ~~
            if(!strict.exo && length(ov.names.x) > 0L) {
                OV <- ov.names.x
                nx <- length(OV)
                idx <- lower.tri(matrix(0, nx, nx), diag = TRUE)
                more.lhs <- rep(OV,  each = nx)[idx] # fill upper.tri
                more.rhs <- rep(OV, times = nx)[idx]
                ov.lhs <- c(ov.lhs, more.lhs)
                ov.rhs <- c(ov.rhs, more.rhs)
                ov.op  <- c(ov.op,  rep("~~", length(more.lhs)))
            }

            # 2b. "~~" lv
            nx <- length(lv.names)
            idx <- lower.tri(matrix(0, nx, nx), diag = TRUE)
            lv.lhs <- rep(lv.names,  each = nx)[idx] # fill upper.tri
            lv.rhs <- rep(lv.names, times = nx)[idx]
            lv.op  <- rep("~~", length(lv.lhs))

            # 3 regressions?
            r.lhs <- r.rhs <- r.op <- character(0)
            if(length(eqs.names) > 0L) {

                r.lhs <- rep(eqs.y, each  = length(eqs.x))
                r.rhs <- rep(eqs.x, times = length(eqs.y))

                # remove self-arrows
                idx <- which(r.lhs == r.rhs)
                if(length(idx) > 0L) {
                    r.lhs <- r.lhs[-idx]
                    r.rhs <- r.rhs[-idx]
                }

                # remove indicator ~ factor if they exist
                bad.idx <- which(r.lhs %in% ov.names.ind &
                                 r.rhs %in% lv.names)
                if(length(bad.idx) > 0L) {
                    r.lhs <- r.lhs[-bad.idx]
                    r.rhs <- r.rhs[-bad.idx]
                }

                r.op <- rep("~", length(r.rhs))
            }

            # 4. intercepts
            int.lhs <- int.rhs <- int.op <- character(0)
            if(meanstructure) {
                if(strict.exo) {
                    int.lhs <- c(ov.names.nox, lv.names)
                } else {
                    int.lhs <- c(ov.names, lv.names)
                }
                int.rhs <- rep("",   length(int.lhs))
                int.op  <- rep("~1", length(int.lhs))
            }

            # 5. thresholds
            th.lhs <- th.rhs <- th.op <- character(0)
            if(length(ov.names.ord) > 0L) {
                th.names <- lavpta$vnames$th[[b]]
                tmp <- strsplit(th.names, "\\|")
                th.lhs <- sapply(tmp, function(x) x[1])
                th.rhs <- sapply(tmp, function(x) x[2])
                th.op  <- rep("|", length(th.lhs))
            }

            # 6. scaling parameters
            delta.lhs <- delta.rhs <- delta.op <- character(0)
            if(ngroups > 1L && length(ov.names.ord) > 0L) {
                delta.lhs <- ov.names.ord
                delta.rhs <- ov.names.ord
                delta.op  <- rep("~*~", length(delta.lhs))
            }

            # combine
            this.lhs <- c(l.lhs, ov.lhs, lv.lhs, r.lhs, int.lhs, th.lhs,
                          delta.lhs)
            this.rhs <- c(l.rhs, ov.rhs, lv.rhs, r.rhs, int.rhs, th.rhs,
                          delta.rhs)
            this.op  <- c(l.op,  ov.op,  lv.op,  r.op,  int.op,  th.op,
                          delta.op)
            n.el <- length(this.lhs)

            lhs   <- c(lhs, this.lhs)
            rhs   <- c(rhs, this.rhs)
            op    <- c(op, this.op)
            block <- c(block, rep(b, n.el))
            group <- c(group, rep(GROUP.values[g], n.el))
            level <- c(level, rep(LEVEL.values[l], n.el))

        } # level
    } # group

    LIST <- data.frame(lhs = lhs, op = op, rhs = rhs, block = block,
                       group = group, level = level, stringsAsFactors = FALSE)

    if(free) {
        LIST$free <- rep(0L, nrow(LIST))
    }

    if(start) {
        LIST$start <- rep(0, nrow(LIST))
    }

    LIST
}