##!
#   path.diagram
#
# Extends path.diagram() in sem package to create a path diagram from 'sem' objects 
# as well as 'mod' objects returned by specify.model() or other RAM specification matrices,
# so that successful sem() fitting is no longer prerequisite for drawing path diagrams.
#
# Example:
#   library(sem)
#   sem.mod <- specify.model()
#     ...
#   path.diagram(sem.mod)
#
# Requirements:
#  This requires the package 'sem'.
#  Tested with R 2.11.1 , sem 0.9-21
#
# @varsion 1.0
# @date 2010-02-27
# @author Masashi Nakanishi
# @license GPL2

# path.diagram(model, file, min.rank = NULL, max.rank = NULL, same.rank = NULL, variables = NULL, parameters = NULL,
#    ignore.double = TRUE, edge.labels = c("names", "values", "both"), size = c(8, 8), node.font = c("Helvetica", 14),
#    edge.font = c("Helvetica", 10), rank.direction = c("LR", "TB"), digits = 2, standardize = FALSE,
#    output.type = c("graphics", "dot"), graphics.fmt = "pdf", dot.options = NULL,
#    S = NULL, obs.variables = NULL, fixed.x = NULL, debug = FALSE, ...)
#
# @param model         a 'sem' object returned by sem::sem(), a 'mod' object returned by sem::specify.model(), or a character or 
#                      numeric matrix for RAM specification
# @param S             data covariance matrix. The same as the argument 'S' in sem::sem(). Either of S and obs.variables is 
#                      required when using a character 'mod' matrix. If fixed.x is specified, S is needed to get fixed values.
# @param obs.variables names of observed variables. The same as the argument 'obs.variables' in sem::sem().
# @param fixed.x       optionally specify names of fixed exogenous variables. The same as the argument 'fixed.x' in sem::sem().
# @param debug         if TRUE, output debug information. The same as the argument 'debug' in sem::sem().
# @param ...           passed to sem::path.diagram()
# @return              same as sem::path.diagram()
path.diagram <-
function (model, file, min.rank = NULL, max.rank = NULL, same.rank = NULL, variables = NULL, parameters = NULL,
    ignore.double = TRUE, edge.labels = c("names", "values", "both"), size = c(8, 8), node.font = c("Helvetica", 14),
    edge.font = c("Helvetica", 10), rank.direction = c("LR", "TB"), digits = 2, standardize = FALSE,
    output.type = c("graphics", "dot"), graphics.fmt = "pdf", dot.options = NULL,
    S = NULL, obs.variables = NULL, fixed.x = NULL, debug = FALSE, ...) 
{
    if (!suppressPackageStartupMessages(require("sem"))) return(invisible(FALSE))
    if (inherits(model, "sem")) {
        cl <- match.call()
        cl[[1L]] <- as.call(list(as.name("::"), as.name("sem"), as.name("path.diagram")))
        if (any((i <- match(c("S", "obs.variables", "fixed.x", "debug"), names(cl), 0L)) > 0L)) cl <- cl[-i]
        eval(cl, parent.frame())
    } else {
        if (inherits(model, "mod") || (is.matrix(model) && is.character(model) && ncol(model) == 3)) {
            if (is.null(S)) {
                if (is.null(obs.variables)) stop("Either S or obs.variables must be specified")
                S <- matrix(nrow=length(obs.variables), ncol=length(obs.variables))
            } else if (is.null(obs.variables)) {
                obs.variables <- rownames(S)
            }
            sem.mod <- sem:::sem.mod
            sem <- function(ram, param.names, var.names, ...) return(list(ram=ram, param.names=param.names, var.names=var.names))
            environment(sem.mod) <- environment()
            ram <- sem.mod(model, S, 0, obs.variables=obs.variables, debug=debug)
            if (is.null(variables))
                variables <- ram$var.names
            if (is.null(parameters))
                parameters <- ram$param.names
            ram <- ram$ram
        } else if (is.matrix(model) && is.numeric(model) && ncol(model) == 5) {
            ram <- model
            if (is.null(variables))
                variables = paste("V", 1:length(unique(as.vector(ram[,2:3]))), sep="")
            if (is.null(parameters))
                parameters = paste("Param", 1:max(ram[,4]), sep="")
        } else
            stop("unsupported class of model argument")

        if (!is.null(fixed.x)) {
            if (is.null(S) || all(is.na(S))) stop("When you use fixed.x, S must be given")
            fixed.pos <- match(fixed.x, rownames(S), 0L)
            if (any(fixed.pos == 0L)) stop("fixed.x are not found in S")
            ram.fixed <- matrix(ncol=5, nrow=length(fixed.pos) * (length(fixed.pos) + 1) / 2)
            for (i in 1:length(fixed.pos)) {
                for (j in 1:i) {
                    ram.fixed[(i-1)*i/2 + j,] <- c(2, fixed.pos[i], fixed.pos[j], 0, S[fixed.pos[i], fixed.pos[j]])
                }
            }
            ram <- rbind(ram, ram.fixed)
        }
        param.labels <- rep("", nrow(ram))
        param.labels[ram[,4L]!=0] <- parameters[ram[ram[,4L]!=0, 4L]]

        model <- list(ram=ram, n=length(obs.variables)) # can leave 'coeff' and 'fixed' unset
        class(model) <- "sem"

        cl <- match.call()
        cl[[1L]] <- as.call(list(as.name("::"), as.name("sem"), as.name("path.diagram")))
        cl[[2L]] <- as.name("model")
        cl[["variables"]] <- as.name("variables")
        cl[["parameters"]] <- as.name("param.labels")
        eval(cl)
    }
}