R/lav_export.R

In yrosseel/lavaan: Latent Variable Analysis

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

lavExport <- function(object, target = "lavaan", prefix = "sem",
                      dir.name = "lavExport", export = TRUE) {
  stopifnot(inherits(object, "lavaan"))
  target <- tolower(target)

  # check for conditional.x = TRUE
  # if(object@Model@conditional.x) {
  #    stop("lavaan 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 == "lavaan") {
    header <- ""
    syntax <- lav2lavaan(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 = c(
        vnames(object@ParTable, "ov"),
        object@Data@sampling.weights
      ),
      ov.ord.names = vnames(object@ParTable, "ov.ord"),
      weight.name = object@Data@sampling.weights,
      listwise = lavInspect(object, "options")$missing == "listwise",
      estimator = lav_mplus_estimator(object),
      information = lavInspect(object, "options")$information,
      meanstructure = lavInspect(object, "meanstructure"),
      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 {
    lav_msg_stop(gettextf("target %s has not been implemented yet", target))
  }

  # 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]])
        }
        if (!is.null(object@Data@weights[[g]])) {
          DATA <- cbind(DATA, object@Data@weights[[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 {
      lav_msg_warn(gettext("not data available"))
    }
    return(invisible(out))
  } else {
    # just return the syntax file for inspection
    class(out) <- c("lavaan.character", "character")
  }

  out
}


lav2check <- function(lav) {
  if (inherits(lav, "lavaan")) {
    lav <- lav@ParTable
  } else if (is.list(lav)) {
    # nothing to do
  } else {
    lav_msg_stop(gettext("lav must be of class `lavaan' 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)
lav2lavaan <- 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("lavaan.character", "character")
  out
}

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

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

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

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