R/lav_export.R

In nietsnel/psindex: Parameter Stability Index

# export `psindex' lav model description to third-party software
# 

lavExport <- function(object, target="psindex", prefix="sem", 
                      dir.name="lavExport", export=TRUE) {

    stopifnot(inherits(object, "psindex"))
    target <- tolower(target)

    # check for conditional.x = TRUE
    if(object@Model@conditional.x) {
        stop("psindex ERROR: this function is not (yet) available if conditional.x = TRUE")
    }

    ngroups <- object@Data@ngroups
    if(ngroups > 1L) {
        group.label2 <- paste(".", object@Data@group.label, sep="")
    } else {
        group.label2 <- ""
    }
    data.file <- paste(prefix, group.label2, ".", target, ".raw", sep="")

    # 2. create syntax file
    if(target == "psindex") {
        header <- ""
        syntax <- lav2psindex(object)
        footer <- ""
        out <- paste(header, syntax, footer, sep="")
    } else if(target == "mplus") {
        header <- lav_mplus_header(data.file=data.file, 
            group.label=object@Data@group.label,
            ov.names=vnames(object@ParTable, "ov"),
            ov.ord.names=vnames(object@ParTable, "ov.ord"),
            estimator=lav_mplus_estimator(object), 
            data.type=object@Data@data.type,
            nobs=object@Data@nobs[[1L]]
            )
        syntax <- lav2mplus(object, group.label=object@Data@group.label)
        footer <- paste("OUTPUT:\n  sampstat standardized tech1;\n")
        out <- paste(header, syntax, footer, sep="")
    } else if(target == "lisrel") {
        syntax <- lav2lisrel(object)
    } else if(target == "eqs") {
        syntax <- lav2eqs(object)
    } else if(target == "sem") {
        syntax <- lav2sem(object)
    } else if(target == "openmx") {
        syntax <- lav2openmx(object)
    } else {
        stop("psindex ERROR: target", target, "has not been implemented yet")
    }
    
    # export to file?
    if(export) {
        dir.create(path=dir.name)
        input.file <- paste(dir.name, "/", prefix, ".", target, ".in", sep="")
        cat(out, file=input.file, sep="")

        # write data (if available)
        if(identical(object@Data@data.type, "full")) {
            for(g in 1:ngroups) {
                if(is.null(object@Data@eXo[[g]])) {
                    DATA <- object@Data@X[[g]]
                } else {
                    DATA <- cbind(object@Data@X[[g]], object@Data@eXo[[g]])
                }
                write.table(DATA,
                            file=paste(dir.name, "/", data.file[g], sep=""),
                            na="-999999",
                            col.names=FALSE, row.names=FALSE, quote=FALSE)
            }
        } else if(identical(object@Data@data.type, "moment")) {
            for(g in 1:ngroups) {
                DATA <- object@SampleStats@cov[[g]]
                write.table(DATA,
                            file=paste(dir.name, "/", data.file[g], sep=""),
                            na="-999999",
                            col.names=FALSE, row.names=FALSE, quote=FALSE)
            }
        } else {
            warning("psindex WARNING: not data available")
        }
        return(invisible(out))
    } else {
        # just return the syntax file for inspection
        class(out) <- c("psindex.character", "character")
    }

    out
}


lav2check <- function(lav) {
    if(inherits(lav, "psindex")) {
        lav <- lav@ParTable
    } else if(is.list(lav)) {
        # nothing to do
    } else {
        stop("psindex ERROR: lav must be of class `psindex' or a parTable")
    }

    # check syntax
    if(is.null(lav$ustart)) lav$ustart <- lav$est

    # check if free is missing
    if(is.null(lav$free)) lav$free <- rep(0L, length(lav$ustart))

    # check if label is missing
    if(is.null(lav$label)) lav$label <- rep("", length(lav$ustart))

    # check if group is missing
    if(is.null(lav$group)) lav$group <- rep(1L, length(lav$ustart))

    # if eq.id not all zero, create labels instead
    #if(!is.null(lav$eq.id) && !all(lav$eq.id == 0L)) {
    #    lav$label <- paste("p",as.character(lav$eq.id), sep="")
    #    lav$label[lav$label == "p0"] <- ""
    #}
 
    lav
}

## FIXME: this is completely UNFINISHED (just  used to quickly get something)
lav2psindex <- lav2lav <- function(lav) {
    lav <- lav2check(lav)
    header <- "# this model syntax is autogenerated by lavExport\n"
    footer <- "\n"

    # intercepts
    int.idx <- which(lav$op == "~1")
    lav$op[int.idx] <- "~"
    lav$rhs[int.idx] <- "1"

    # spacing around operator
    lav$op <- paste(" ",lav$op, " ", sep="")

    lav2 <- ifelse(lav$free != 0L,
                   ifelse(lav$label == "",
                          paste(lav$lhs, lav$op, lav$rhs, sep=""),
                          paste(lav$lhs, lav$op, lav$label, "*", lav$rhs, 
                                sep="")
                   ),
                   ifelse(lav$label == "",
                          paste(lav$lhs, lav$op, lav$ustart, "*", lav$rhs, 
                                sep=""),
                          paste(lav$lhs, lav$op, lav$ustart, "*", lav$rhs, 
                                "+", lav$label, "*", lav$rhs, sep="")
                   )
            )

    body <- paste(lav2, collapse="\n")
    out <- paste(header, body, footer, sep="")
    class(out) <- c("psindex.character", "character")
    out
}

lav2lisrel <- function(lav) {
    lav <- lav2check(lav)
    stop("this function needs revision")
}

lav2eqs <- function(lav) {
    lav <- lav2check(lav)
    stop("this function needs revision")
}

lav2sem <- function(lav) {
    lav <- lav2check(lav)
    stop("this function needs revision")
}

lav2openmx <- function(lav) {
    lav <- lav2check(lav)
    stop("this function needs revision")
}