semPlot/0000755000176200001440000000000014274657172011714 5ustar liggesuserssemPlot/NAMESPACE0000644000176200001440000000343614267410262013126 0ustar liggesusersexport(semPaths,semPlotModel,semCors,lisrelModel,ramModel,semSyntax, semMatrixAlgebra,modelMatrices,Imin,semPlotModel_lavaanModel) # export Classes exportClasses( "semPlotModel" ) # export Methods exportMethods( "semPlotModel_S4" ) S3method("+",semPlotModel) S3method(semPlotModel,list) S3method(semPlotModel,lm) S3method(semPlotModel,principal) S3method(semPlotModel,princomp) S3method(semPlotModel,loadings) S3method(semPlotModel,lisrel) S3method(semPlotModel,factanal) S3method(semPlotModel,default) S3method(semPlotModel,mplus.model) S3method(semPlotModel,sem) S3method(semPlotModel,msem) S3method(semPlotModel,msemObjectiveML) export(semPlotModel_Onyx) export(semPlotModel_Amos) export(exo,"exo<-",endo,"endo<-",lat,"lat<-",man,"man<-") S3method(semPlotModel,regsem) S3method(semPlotModel,cvregsem) # importFrom(MplusAutomation,"readModels") importFrom(sem,"sem","standardizedCoefficients","specifyModel") importFrom(lavaan,"lavaan","cfa","standardizedSolution", "standardizedsolution", "parameterEstimates", "parameterestimates","inspect","lavaanNames","lavaanify","lavInspect","lavTech") importClassesFrom(lavaan,"lavaan") importFrom(stats,"factanal") importFrom(rockchalk,standardize) #importFrom(regsem, "regsem","cv_regsem") import(plyr) import(lisrelToR) import(XML) import(qgraph) import(methods) import(OpenMx) #import(semTools) importFrom(igraph,"layout.reingold.tilford","graph.edgelist","shortest.paths") importFrom(colorspace,rainbow_hcl) importFrom(corpcor,"pseudoinverse") importFrom("grDevices", "col2rgb", "rainbow", "rgb") importFrom("graphics", "lines", "par", "text") importFrom("stats", "ave", "coef", "cov", "cov2cor", "loadings", "median", "pnorm", "weighted.mean") importFrom("utils", "packageDescription") semPlot/README0000644000176200001440000000021414267410262012556 0ustar liggesusersPath diagrams and visual analysis of various SEM packages' output. Please ask questions here or on http://sachaepskamp.com/forums/semPlot. semPlot/man/0000755000176200001440000000000014267410262012454 5ustar liggesuserssemPlot/man/semSyntax.Rd0000644000176200001440000000540014267410262014735 0ustar liggesusers\name{semSyntax} \alias{semSyntax} \title{ Produce model syntax for various SEM software } \description{ This function produces a model object or model syntax for SEM software based on a \code{\link{semPlotModel-class}} object. If the input is not a \code{"semPlotModel"} object the \code{\link{semPlotModel}} function is run on the input. This allows to create model syntax for one program based on the output of another program. Currently only the R packages 'lavaan' (Rosseel, 2012) and 'sem' (Fox, Nie & Byrnes, 2012) are supported. } \usage{ semSyntax(object, syntax = "lavaan", allFixed = FALSE, file) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{object}{ A "semPlotModel" object or any of the input possibilities for \code{\link{semPlotModel}}. } \item{syntax}{ A string indicating which syntax to be used for the output. Currently supported are \code{'lavaan'} and \code{'sem'}. } \item{allFixed}{ Logical, should all parameters be fixed to their estimate. Useful for simulating data. } \item{file}{ Path of a file the model should be written to. } } \value{ A string containing the \code{lavaan} model syntax or a \code{"semmod"} object for the \code{sem} package. } \references{ Yves Rosseel (2012). lavaan: An R Package for Structural Equation Modeling. Journal of Statistical Software, 48(2), 1-36. URL http://www.jstatsoft.org/v48/i02/. John Fox, Zhenghua Nie and Jarrett Byrnes (2012). sem: Structural Equation Models. R package version 3.0-0. http://CRAN.R-project.org/package=sem } \author{ Sacha Epskamp } \seealso{ \code{\link{semPlotModel}} \code{\link{semPlotModel-class}} \code{\link{semPaths}} } \examples{ # MIMIC model, example 5.8 from mplus user guide: tryres <- try({ Data <- read.table("http://www.statmodel.com/usersguide/chap5/ex5.8.dat") }) if (!is(tryres,"try-error")){ names(Data) <- c(paste("y", 1:6, sep=""), paste("x", 1:3, sep="")) # Data <- Data[,c(7:9,1:6)] # Model: model.Lavaan <- 'f1 =~ y1 + y2 + y3 f2 =~ y4 + y5 + y6 f1 + f2 ~ x1 + x2 + x3 ' # Run Lavaan: library("lavaan") fit.Lavaan <- lavaan:::cfa(model.Lavaan, data=Data, std.lv=TRUE) # Obtain Lavaan syntax: model.Lavaan2 <- semSyntax(fit.Lavaan, "lavaan") # Run Lavaan again: fit.Lavaan2 <- lavaan:::lavaan(model.Lavaan2, data=Data) # Compare models: layout(t(1:2)) semPaths(fit.Lavaan,"std",title=FALSE) title("Lavaan model 1",line=3) semPaths(fit.Lavaan2, "std",title=FALSE) title("Lavaan model 2",line=3) # Convert to sem model: model.sem <- semSyntax(fit.Lavaan, "sem") # Run sem: library("sem") fit.sem <- sem:::sem(model.sem, data = Data) # Compare models: layout(t(1:2)) semPaths(fit.Lavaan,"std",title=FALSE) title("Lavaan",line=3) semPaths(fit.sem, "std",title=FALSE) title("sem",line=3) } } semPlot/man/semPlotModel.S4-methods.Rd0000644000176200001440000000101714267410262017274 0ustar liggesusers\name{semPlotModel_S4-methods} \docType{methods} \alias{semPlotModel_S4-methods} \alias{semPlotModel_S4,lavaan-method} \alias{semPlotModel_S4} \title{ S4 methods for semPlotModel } \description{ S4 generic used only for the \code{\link[lavaan]{lavaan-class}} class. See \code{\link{semPlotModel}} for more information and \code{\link{semPlotModel-class}} for the resulting object. } \section{Methods}{ \describe{ \item{\code{signature(object = "lavaan")}}{ A \code{\link[lavaan]{lavaan-class}} object. } }} \keyword{methods} semPlot/man/tricks.Rd0000644000176200001440000000241114267410262014240 0ustar liggesusers\name{semPlot-tricks} \alias{+.semPlotModel} \alias{semPlotModel.list} \title{ Tricks that can be used in semPlot. } \description{ Use a list contaning several SEM objects (from any source) to plot them as the same model. Also, the '+' operator can be used to combine two models, including in calls in \code{\link{semPaths}} and \code{\link{semPlotModel}}. See examples. } \usage{ \method{+}{semPlotModel}(x,y) \method{semPlotModel}{list}(object, \dots) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ A \code{"semPlotModel"} object } \item{y}{ A \code{"semPlotModel"} object } \item{object}{ An object contaning the result of a SEM or GLM analysis, or a string contaning the file path to the output file of a sEM program. } \item{\dots}{ Not used. } } \author{ Sacha Epskamp } \seealso{ \code{\link{semPlotModel}} \code{\link{semPaths}} \code{\link{semCors}} } \examples{ # A silly dataset: A <- rnorm(100) B <- A + rnorm(100) C <- B + rnorm(100) DF <- data.frame(A,B,C) # Two regressions: res1 <- lm(B ~ C, data = DF) res2 <- lm(A ~ B + C, data = DF) # Plot both in the same path diagram in two ways: semPaths(res1 + res2, "model", "est", intercepts=FALSE) semPaths(list(res1,res2), "model", "est", intercepts=FALSE) }semPlot/man/semMatrixAlgebra.Rd0000644000176200001440000000652014267412250016174 0ustar liggesusers\name{semMatrixAlgebra} \alias{semMatrixAlgebra} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Extract or calculate with model matrices } \description{ This function can be used to extract or calculate with model matrices given a \code{"semMatriModel"} object (from \code{\link{modelMatrices}}) or a \code{"semPlotModel"} object or any of the input types that can be used in \code{\link{semPlotModel}} directly. If the model is not specified it is attempted to be identified by the given algebra. } \usage{ semMatrixAlgebra(object, algebra, group, simplify = TRUE, model, endoOnly = FALSE) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{object}{ A \code{"semMatriModel"} object (from \code{\link{modelMatrices}}) or a \code{"semPlotModel"} object or any of the input types that can be used in \code{\link{semPlotModel}} directly. } \item{algebra}{ An R expression to use. } \item{group}{ Groups the algebra should be used on. If more than one a list is returned with the result for each group. } \item{simplify}{ If TRUE and only one group is used, return output as is instead of in a list. } \item{model}{ Model to be used in \code{\link{modelMatrices}}, \code{"mplus"}, \code{"ram"} or \code{"lisrel"} } \item{endoOnly}{ Only needed when the model is \code{"lisrel"}, sets all variables to endogenous. } } \details{ The \code{"lisrel"} model uses the following matrix names: \code{LY}, \code{TE}, \code{PS}, \code{BE}, \code{LX}, \code{TD}, \code{PH}, \code{GA}, \code{TY}, \code{TX}, \code{AL} and \code{KA}. The \code{"mplus"} model uses the following matrix names: \code{Lambda}, \code{Nu}, \code{Theta}, \code{Kappa}, \code{Alpha}, \code{Beta}, \code{Gamma} and \code{Psi}. The \code{"ram"} model uses the following matrix names: \code{F}, \code{A} and \code{S}. } \value{ A list containing output per group } \author{ Sacha Epskamp } \seealso{ \code{\link{semPlotModel}} \code{\link{semPlotModel-class}} \code{\link{modelMatrices}} \code{\link{lisrelModel}} \code{\link{ramModel}} } \examples{ ## Mplus user guide SEM example: outfile <- tempfile(fileext=".out") tryres <- try({ download.file("http://www.statmodel.com/usersguide/chap5/ex5.11.html",outfile) }) if (!is(tryres,"try-error")){ # Plot model: semPaths(outfile,intercepts=FALSE) # Obtain latent regressions (mplus) semMatrixAlgebra(outfile, Beta) # mplus model implied covariance: mat1 <- semMatrixAlgebra(outfile, Lambda \%*\% Imin(Beta, TRUE) \%*\% Psi \%*\% t(Imin(Beta, TRUE)) \%*\% t(Lambda) + Theta) # Lisrel model implied covariance: mat2 <- semMatrixAlgebra(outfile, LY \%*\% Imin(BE, TRUE) \%*\% PS \%*\% t(Imin(BE, TRUE)) \%*\% t(LY) + TE, endoOnly = TRUE) # RAM model implied covariance: mat3 <- semMatrixAlgebra(outfile, F \%*\% Imin(A,TRUE) \%*\% S \%*\% t(Imin(A, TRUE)) \%*\% t(F)) \dontrun{ # Plot: library("qgraph") pdf("Models.pdf",width=15,height=5) layout(t(1:3)) qgraph(round(cov2cor(mat1),5), maximum=1, edge.labels=TRUE, layout = "spring", cut = 0.4, minimum = 0.1) title("Mplus model") qgraph(round(cov2cor(mat2),5), maximum=1, edge.labels=TRUE, layout = "spring", cut = 0.4, minimum = 0.1) title("LISREL model") qgraph(round(cov2cor(mat3),5), maximum=1, edge.labels=TRUE, layout = "spring", cut = 0.4, minimum = 0.1) title("RAM model") dev.off() } # They are the same. } } semPlot/man/semPlot-package.Rd0000644000176200001440000000131314267410262015755 0ustar liggesusers\name{semPlot-package} \alias{semPlot-package} \alias{semPlot} \docType{package} \title{ semPlot } \description{ Path diagrams and visual analysis of various SEM packages' output. Path diagrams including visualizations of the parameter estimates can be plotted with \code{\link{semPaths}} and visualizations of the implied and observed correlation structures can be plotted using \code{\link{semCors}}. Finally, SEM syntax can be generated using\code{\link{semSyntax}}. For plotting the graphs the \code{\link[qgraph]{qgraph}} package is used. } \author{ Sacha Epskamp (mail@sachaepskamp.com) Maintainer: Sacha Epskamp } \references{ github.com/SachaEpskamp/semPlot } \keyword{ package }semPlot/man/lisrelModel.Rd0000644000176200001440000001322414267410262015220 0ustar liggesusers\name{lisrelModel} \alias{lisrelModel} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Construct SEM model using LISREL matrix specification. } \description{ This function creates a 'semPlotModel' object using matrices of the extended LISREL model (Joreskog & Sorbom, 1996). This function has two main purposes. First, it can be used to easilly create path diagrams of arbitrary SEM models without having to run an actual analysis. And second, it is specifically designed to work with the output of the 'lisrelToR' package (using \code{do.call(lisrelModel,output$matrices)}). Using \code{\link{semPaths}} or \code{\link{semPlotModel}} on the file path of a LISREL output file will automatically first run \code{\link[lisrelToR]{readLisrel}} and then this function. } \usage{ lisrelModel(LY, PS, BE, TE, TY, AL, manNamesEndo, latNamesEndo, LX, PH, GA, TD, TX, KA, manNamesExo, latNamesExo, ObsCovs, ImpCovs, setExo, modelLabels = FALSE, reduce) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{LY}{ Specification of the Lambda-Y matrix. See details. } \item{PS}{ Specification of the Psi matrix. See details. } \item{BE}{ Specification of the Beta matrix. See details. } \item{TE}{ Specification of the Theta-Epsilon matrix. See details. } \item{TY}{ Specification of the Tau-Y matrix. See details. } \item{AL}{ Specification of the Alpha matrix. See details. } \item{manNamesEndo}{ Character vector of names for the endogenous manifests. } \item{latNamesEndo}{ Character vector of names for the endogenous latents. } \item{LX}{ Specification of the Lambda-X matrix. See details. } \item{PH}{ Specification of the Phi matrix. See details. } \item{GA}{ Specification of the Gamma matrix. See details. } \item{TD}{ Specification of the Theta-Delta matrix. See details. } \item{TX}{ Specification of the Tau-X matrix. See details. } \item{KA}{ Kappa } \item{manNamesExo}{ Character vector of names for the exogenous manifests. } \item{latNamesExo}{ Character vector of names for the exogenous latents. } \item{ObsCovs}{ The observed covariance matrix, or a list of such matrices for each group. } \item{ImpCovs}{ The implied covariance matrix, or a list of such matrices for each group. } \item{setExo}{ Logical. If TRUE the 'exogenous' variable in the Variables data frame is specified. This forces \code{\link{semPaths}} to not attempt to identify which variables are endogenous and exogenous. } \item{modelLabels}{ Logical. If TRUE all labels are set to the LISREL model matrix terms, as expressions. When plotted with \code{\link{semPaths}} this requires the argument \code{as.expression=c("nodes","edges")}. } \item{reduce}{ Logical indicating if the variable number should be reduced if multiple variables are named exactly the same. If TRUE (default) directed edges between nodes that are named the same are removed and the manifest node is kept, as this usually indicates a way to include manifest variables in regressions.} } \details{ The LISREL matrices can be assigned in various ways, depending on the amount of information that should be stored in the resulting model. First, the a single matrix can be used. The values of this matrix correspond to the parameter estimates in the 'semPlotModel'. For multiple groups, a list of such matrices can be used. to store more information, a named list of multiple matrices of the same dimensions can be used. Included in this list can be the following (but only estimates is nessesary): \describe{ \item{\code{est}}{Parameter estimates} \item{\code{std}}{standardized parameter estimates} \item{\code{par}}{Parameter numbers. 0 indicating fixed variables and parameters with the same parameter number are constrained to be equal.} \item{\code{fixed}}{Logical matrix indicating if the parameter is fixed.} } If \code{std} is missing the function tries to compute standardized solutions (not yet working for intercepts). If \code{fixed} is missing it is computed from the \code{par} matrix. For multiple groups, a list containing such lists can be used. The number of variables is extracted from the assigned matrices. Matrices that are not assigned are assumed to be empty matrices of the appropriate dimensions. e.g., Lambda-Y is assumed to be a 0 by 0 matrix if there are no endogenous variables. } \value{ A 'semPlotModel' object. } \references{ Joreskog, K. G., & Sorbom, D. (1996). LISREL 8 user's reference guide. Scientific Software. https://github.com/SachaEpskamp/lisrelToR } \author{ Sacha Epskamp } \seealso{ \code{\link{semPlotModel}} \code{\link{semCors}} \code{\link{semPaths}} \code{\link{ramModel}} } \examples{ ## Example of a Full LISREL model path diagram with the same number of exgenous ## and endogenous variables: # Lambda matrices: Loadings <- rbind(diag(1,2,2),diag(1,2,2),diag(1,2,2)) # Phi and Psi matrices: LatVar <- diag(1,2,2) # Beta matrix: Beta <- matrix(0,2,2) Beta[1,2] <- 1 # Theta matrices: ManVar <- diag(1,nrow(Loadings),nrow(Loadings)) # Gamma matrix: Gamma <- diag(1,2,2) # Tau matrices: ManInts <- rep(1,6) # Alpha and Kappa matrices: LatInts <- rep(1,2) # Combine model: mod <- lisrelModel(LY=Loadings,PS=LatVar,BE=Beta,TE=ManVar, LX=Loadings,PH=LatVar,GA=Gamma,TD=ManVar, TY=ManInts,TX=ManInts,AL=LatInts,KA=LatInts) # Plot path diagram: semPaths(mod, as.expression=c("nodes","edges"), sizeMan = 3, sizeInt = 1, sizeLat = 4) # Plot path diagram with more graphical options: semPaths(mod, as.expression=c("nodes","edges"), sizeMan = 3, sizeInt = 1, sizeLat = 4, label.prop=0.5, curve=0.5, bg="black", groups="latents", intercepts=FALSE, borders=FALSE, label.norm="O") } semPlot/man/semPlotModel.Rd0000644000176200001440000000415614267410262015355 0ustar liggesusers\name{semPlotModel} \alias{semPlotModel} \alias{semPlotModel.default} \alias{semPlotModel.lm} \alias{semPlotModel.principal} \alias{semPlotModel.princomp} \alias{semPlotModel.loadings} \alias{semPlotModel.factanal} % \alias{semPlotModel.lavaan} \alias{semPlotModel.lisrel} % \alias{semPlotModel.semspec} \alias{semPlotModel.mplus.model} \alias{semPlotModel.sem} \alias{semPlotModel.msem} \alias{semPlotModel.msemObjectiveML} \alias{semPlotModel_Amos} \alias{semPlotModel_Onyx} \alias{semPlotModel_lavaanModel} \title{ SEM model representation } \description{ Methods to read a SEM object and return a \code{\link{semPlotModel-class}} object. } \usage{ \method{semPlotModel}{default}(object, \dots) \method{semPlotModel}{lm}(object, \dots) \method{semPlotModel}{principal}(object, \dots) \method{semPlotModel}{princomp}(object, \dots) \method{semPlotModel}{loadings}(object, \dots) \method{semPlotModel}{factanal}(object, \dots) % \method{semPlotModel}{lavaan}(object) \method{semPlotModel}{lisrel}(object, \dots) % \method{semPlotModel}{semspec}(object) \method{semPlotModel}{mplus.model}(object, mplusStd = c("std", "stdy", "stdyx"), \dots) \method{semPlotModel}{sem}(object, \dots) \method{semPlotModel}{msem}(object, \dots) \method{semPlotModel}{msemObjectiveML}(object, \dots) semPlotModel_Amos(object) semPlotModel_Onyx(object) semPlotModel_lavaanModel(object, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{object}{ An object contaning the result of a SEM or GLM analysis, or a string contaning the file path to the output file of a SEM program. Or a Lavaan model. } \item{mplusStd}{ What standardization to use in Mplus models? } \item{model}{ The original sem model (used in cvregsem) } \item{\dots}{Arguments sent to 'lisrelModel', not used in other methods.} } \details{ A detailed overview of which packages are supported and what is supported for each of them will soon be on my website. } \value{ A \code{"semPlotModel"} object. See \code{link{semPlotModel-class}} } \author{ Sacha Epskamp } \seealso{ \code{\link{semPaths}} \code{\link{semCors}} \code{\link{semPlotModel-class}} } semPlot/man/ramModel.Rd0000644000176200001440000000526114267410262014507 0ustar liggesusers\name{ramModel} \alias{ramModel} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Construct SEM model using RAM matrix specification. } \description{ This function creates a 'semPlotModel' object using matrices of the RAM model (McArdle & McDonald, 1984). } \usage{ ramModel(A, S, F, M, manNames, latNames, Names, ObsCovs, ImpCovs, modelLabels = FALSE) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{A}{ Specification of the assymmetric (A) matrix, see details. } \item{S}{ Specification of the symmetric (S) matrix, see details. } \item{F}{ Specification of the filter (F) matrix, see details. } \item{M}{ Specification of the means (M) vector, see details. } \item{manNames}{ Character vector of the manifest names. } \item{latNames}{ Character vector of the latent names. } \item{Names}{ Character vector containing all names. Defaults to \code{c(manNames,latNames)}. } \item{ObsCovs}{ Observed covariancem matrix. } \item{ImpCovs}{ Implied covariancem matrix. } \item{modelLabels}{ Logical. If \code{TRUE} all latents are named \code{l1, l2, ...} and all manifests \code{m1, m2, ...} } } \details{ The matrices can be assigned in various ways, depending on the amount of information that should be stored in the resulting model. First, the a single matrix can be used. The values of this matrix correspond to the parameter estimates in the 'semPlotModel'. For multiple groups, a list of such matrices can be used. to store more information, a named list of multiple matrices of the same dimensions can be used. Included in this list can be the following (but only estimates is nessesary): \describe{ \item{\code{est}}{Parameter estimates} \item{\code{std}}{standardized parameter estimates} \item{\code{par}}{Parameter numbers. 0 indicating fixed variables and parameters with the same parameter number are constrained to be equal.} \item{\code{fixed}}{Logical matrix indicating if the parameter is fixed.} } If \code{std} is missing the function tries to compute standardized solutions (not yet working for intercepts). If \code{fixed} is missing it is computed from the \code{par} matrix. For multiple groups, a list containing such lists can be used. The number of variables is extracted from the assigned matrices. } \value{ A 'semPlotModel' object. } \references{ McArdle, J. J., & McDonald, R. P. (1984). Some algebraic properties of the reticular action model for moment structures. British Journal of Mathematical and Statistical Psychology, 37(2), 234-251. } \author{ Sacha Epskamp } \seealso{ \code{\link{semPlotModel}} \code{\link{semCors}} \code{\link{semPaths}} \code{\link{lisrelModel}} } semPlot/man/cvregsemplot.Rd0000644000176200001440000000321514267410262015456 0ustar liggesusers\name{cvregsem} \alias{semPlotModel.cvregsem} \title{ Bridge between cv_regsem output and sempaths } \description{ The package regsem (Jacobucci, 2017) is designed for a specific type of SEM called regularized structural equation modelling (RegSEM). For more information about RegSEM and the implementation in R we refer to the manual written by Jacobucci (2017).This function creates a bridge between the regsem and semplot packages, making it possible to use output from the regsem() and cv_regsem() functions to create models in sempaths. } \usage{ \method{semPlotModel}{cvregsem}(object,model,\dots) } \arguments{ \item{object}{ The regsem output } \item{model}{ The cfa output used as input for the cv_regsem function } \item{\dots}{ Arguments sent to 'lisrelModel', not used in other methods. } } \value{ A 'semPlotModel' object. } \references{ Jacobucci, R. (2017). regsem: Regularized Structural Equation Modeling. arXiv preprint arXiv:1703.08489. } \author{ Sacha Epskamp Jason Nak Myrthe Veenman } \seealso{ \code{\link{semPlotModel}} \code{\link{semPaths}} } \examples{ ## Example of fitting and plotting a cv_regsem model in semPaths #library(psych) #library(lavaan) #library(regsem) # use a subset of the BFI #bfi2 <- bfi[1:250,c(1:5,18,22)] #bfi2[,1] <- reverse.code(-1,bfi2[,1]) # specify a SEM model #mod <- " #f1 =~ NA*A1+A2+A3+A4+A5+O2+N3 #f1~~1*f1 #" # fit the model #fit <- cfa(mod, bfi2) #out.reg <- cv_regsem(fit, type="lasso", pars_pen=c(1:7), n.lambda=23, jump =.05) # plot the model #semPaths(semPlotModel.cvregsemplot(object = out.reg, model = fit)) } semPlot/man/regsemplot.Rd0000644000176200001440000000306614267410262015131 0ustar liggesusers\name{regsem} \alias{semPlotModel.regsem} \title{ Bridge between regsem output and sempaths } \description{ The package regsem (Jacobucci, 2017) is designed for a specific type of SEM called regularized structural equation modelling (RegSEM). For more information about RegSEM and the implementation in R we refer to the manual written by Jacobucci (2017).This function creates a bridge between the regsem and semplot packages, making it possible to use output from the regsem() and cv_regsem() functions to create models in sempaths. } \usage{ \method{semPlotModel}{regsem}(object,\dots) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{object}{ The regsem output } \item{\dots}{Arguments sent to 'lisrelModel', not used in other methods.} } \value{ A 'semPlotModel' object. } \references{ Jacobucci, R. (2017). regsem: Regularized Structural Equation Modeling. arXiv preprint arXiv:1703.08489. } \author{ Sacha Epskamp Myrthe Veenman Jason Nak } \seealso{ \code{\link{semPlotModel}} \code{\link{semPaths}} } \examples{ \dontrun{ ## Example of fitting and plotting a regsem model in semPaths library(psych) library(lavaan) library(regsem) # use a subset of the BFI bfi2 <- bfi[1:250,c(1:5,18,22)] bfi2[,1] <- reverse.code(-1,bfi2[,1]) # specify a SEM model mod <- " f1 =~ NA*A1+A2+A3+A4+A5+O2+N3 f1~~1*f1 " # fit the model fit <- cfa(mod, bfi2) out.reg <- regsem(fit, type="lasso", pars_pen=c(1:7)) # plot the model semPaths(semPlotModel.regsem(object = out.reg)) } }semPlot/man/modelMatrices.Rd0000644000176200001440000000451314267411553015542 0ustar liggesusers\name{modelMatrices} \alias{modelMatrices} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Extract SEM model matrices } \description{ Create a \code{"semMatriModel"} object. Use \code{\link{semMatrixAlgebra}} to extract or compute with these models. The structure of \code{"semMatriModel"} objects is chosen such that they can be used to create a \code{\link{semPlotModel-class}} object using \code{do.call} in combination with \code{\link{ramModel}}, \code{\link{lisrelModel}} or \code{mplusModel} (not yet implemented). See details. } \usage{ modelMatrices(object, model = "ram", endoOnly = FALSE) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{object}{ A \code{"semPlotModel"} object or any of the input types that can be used in \code{\link{semPlotModel}} directly. } \item{model}{ Model to be used, \code{"mplus"}, \code{"ram"} or \code{"lisrel"} } \item{endoOnly}{ Only needed when the model is \code{"lisrel"}, sets all variables to endogenous. } } \details{ The \code{"lisrel"} model uses the following matrix names: \code{LY}, \code{TE}, \code{PS}, \code{BE}, \code{LX}, \code{TD}, \code{PH}, \code{GA}, \code{TY}, \code{TX}, \code{AL} and \code{KA}. Regressions on manifest variables will cause dummy latents to be included in the model. The \code{"mplus"} model uses the following matrix names: \code{Lambda}, \code{Nu}, \code{Theta}, \code{Kappa}, \code{Alpha}, \code{Beta}, \code{Gamma} and \code{Psi}. The \code{"ram"} model uses the following matrix names: \code{F}, \code{A} and \code{S}. } \value{ a \code{"semMatriModel"} object } \author{ Sacha Epskamp } \seealso{ \code{\link{semPlotModel}} \code{\link{semPlotModel-class}} \code{\link{semMatrixAlgebra}} \code{\link{lisrelModel}} \code{\link{ramModel}} } \examples{ ## Mplus user guide SEM example: outfile <- tempfile(fileext=".out") tryres <- try({ download.file("http://www.statmodel.com/usersguide/chap5/ex5.11.html",outfile) }) if (!is(tryres,"try-error")){ # Plot model: semPaths(outfile, intercepts = FALSE) # Extract RAM: RAM <- modelMatrices(outfile, "ram") semPaths(do.call(ramModel, RAM), as.expression = "edges", intercepts = FALSE) # Extract LISREL: LISREL <- modelMatrices(outfile, "lisrel") semPaths(do.call(lisrelModel, LISREL), as.expression = "edges", intercepts = FALSE) } } semPlot/man/Imin.Rd0000644000176200001440000000102314267410262013633 0ustar liggesusers\name{Imin} \alias{Imin} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Helper function to substract matrix from identity matrix and take inverse. } \description{ This function can be used to more easilly compute I - X or (I - X)^(-1), which are common in SEM models. } \usage{ Imin(x, inverse = FALSE) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ A matrix } \item{inverse}{ Logical, should the inverse be taken? } } \author{ Sacha Epskamp } semPlot/man/edits.Rd0000644000176200001440000000123714267410262014056 0ustar liggesusers\name{semPlotModel-edit} \alias{semPlotModel-edit} \alias{exo} \alias{exo<-} \alias{endo} \alias{endo<-} \alias{man} \alias{man<-} \alias{lat} \alias{lat<-} \title{ Functions to facilitate editting 'semPlotModel' objects. } \description{ These functions can be used to easilly call and edit parts of a \code{\link{semPlotModel-class}} object. Currently only manifest/latent and endgenous/exogenous node properties can be set. } \usage{ exo(x) endo(x) man(x) lat(x) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ A \code{"semPlotModel"} object } } \author{ Sacha Epskamp } \seealso{ \code{\link{semPlotModel}} } semPlot/man/semCors.Rd0000644000176200001440000000231414267410262014356 0ustar liggesusers\name{semCors} \alias{semCors} \title{ Visually inspect implied and observed correlations } \description{ This function is still in devellopment. } \usage{ semCors(object, include, vertical = TRUE, titles = FALSE, layout, maximum, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{object}{ A \code{semPlotModel} object } \item{include}{ What to include? Can be \code{"observed"}, \code{"implied"} or \code{"difference"}, or a vector containing both. Defaults to showing observed and implied covariances. } \item{vertical}{ Should the layout be vertical or horizontal? } \item{titles}{ Logical, should titles indicating the group and observed/implied correlations be plotted? } \item{layout}{ An optional layout matrix send to \code{\link[qgraph]{qgraph}}. } \item{maximum}{ The maximum values as used in \code{\link[qgraph]{qgraph}}. Defaults to 1 for observed and implied covariances and 0.1 for difference graph. Important to note: Setting this lower than any of the covariances when comparing observed and implied correlations makes these graphs NOT interpretable. } \item{\dots}{ Arguments sent to \code{\link[qgraph]{qgraph}} } } \author{ Sacha Epskamp } semPlot/man/semPaths.Rd0000644000176200001440000010621314267412205014531 0ustar liggesusers\name{semPaths} \alias{semPaths} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Plot path diagram for SEM models. } \description{ This function creates a path diagram of a SEM model (or general linear model), which is then plotted using \code{\link[qgraph]{qgraph}}. Currently many different SEM programs and packages are supported. Please see my website (www.sachaepskamp.com) for more details on which packages are supported and what is supported for each package. } \usage{ semPaths(object, what = "paths", whatLabels, style, layout = "tree", intercepts = TRUE, residuals = TRUE, thresholds = TRUE, intStyle = "multi", rotation = 1, curve, curvature = 1, nCharNodes = 3, nCharEdges = 3, sizeMan = 5, sizeLat = 8, sizeInt = 2, sizeMan2, sizeLat2, sizeInt2, shapeMan, shapeLat, shapeInt = "triangle", ask, mar, title, title.color = "black", title.adj = 0.1, title.line = -1, title.cex = 0.8, include, combineGroups = FALSE, manifests, latents, groups, color, residScale, gui = FALSE, allVars = FALSE, edge.color, reorder = TRUE, structural = FALSE, ThreshAtSide = FALSE, thresholdColor, thresholdSize = 0.5, fixedStyle = 2, freeStyle = 1, as.expression = character(0), optimizeLatRes = FALSE, inheritColor = TRUE, levels, nodeLabels, edgeLabels, pastel = FALSE, rainbowStart = 0, intAtSide, springLevels = FALSE, nDigits = 2, exoVar, exoCov = TRUE, centerLevels = TRUE, panelGroups = FALSE, layoutSplit = FALSE, measurementLayout = "tree", subScale, subScale2, subRes = 4, subLinks, modelOpts = list(mplusStd = "std"), curveAdjacent = '<->', edge.label.cex = 0.6, cardinal = "none", equalizeManifests = FALSE, covAtResiduals = TRUE, bifactor, optimPoints = 1:8 * (pi/4), ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{object}{ A \code{"semPlotModel"} object or any of the input types that can be used in \code{\link{semPlotModel}} directly. } \item{what}{ What should the edges indicate in the path diagram? This function uses \code{\link{grepl}} to allow fuzzy matching and is not case sensitive. E.g., \code{par} will also match \code{Parameters}. \describe{ \item{\code{path}, \code{diagram} or \code{mod}}{This will display the model as an unweighted network (gray edges by default).} \item{\code{est} or \code{par}}{This will display the parameter estimates as weighted edges.} \item{\code{stand} or \code{std}}{This will display the standardized parameter estimates, if available, as weighted edges.} \item{\code{eq} or \code{cons}}{This is the same graph as \code{path}. except that parameters with equality constraints are now colored. Parameters with the same color are constrained to be equal.} \item{\code{col}}{This will create an unweighted graph of the path diagram, where edges are colored with a mix of the colors of connected nodes.} } } \item{whatLabels}{ What should the edge labels indicate in the path diagram? This function uses \code{\link{grepl}} to allow fuzzy matching and is not case sensitive. E.g., \code{par} will also match \code{Parameters}. Default depends on the \code{what} argument, defaulting to the respective elements in the list below for values of \code{what} in the list above. \describe{ \item{\code{name}, \code{label}, \code{path} or \code{diagram}}{This will display the edge names as labels.} \item{\code{est} or \code{par}}{This will display the parameter estimate in edge labels.} \item{\code{stand} or \code{std}}{This will display the standardized parameter estimate in edge labels.} \item{\code{eq} or \code{cons}}{This will display the parameter number in edge labels. 0 indicates the parameter is fixed, parameters with the same parameter number are constrained to be equal.} \item{\code{no}, \code{omit}, \code{hide} or \code{invisible}}{Hides edge labels.} } } \item{style}{ The style to use. Currently only indicates what the (residual) variances look like. Use \code{"ram"}, \code{"mx"} or \code{"OpenMx"} for double headed selfloops and \code{"lisrel"} for single headed edges with no node as origin. Defaults to \code{"ram"} unless the input is a lisrel model. } \item{layout}{ A string indicating how the nodes should be placed. Similar to the 'layout' argument in \code{\link[qgraph]{qgraph}}. Can be one of the following strings. \describe{ \item{tree}{The integrated tree-like layout. Places exogenous variables at the top and endogenous variables at the bottom. See 'details' for more details.} \item{circle}{The same layout as "tree", except that afterwards the horizontal levels of the layout are placed in circles. Especially useful for models with a large number of manifest variables and a relatively small number of latent variables.} \item{spring}{Calls the "spring" layout in \code{\link[qgraph]{qgraph}}, which uses the Fruchterman-reingold algorithm (Fruchterman & Reingold, 1991).} \item{tree2}{Calls the \code{layout.reingold.tilford} function from the igraph package (Csardi & Nepusz, 2006), which uses the Reingold-Tilford algorithm (Reingold & Tilford, 1981). Before calling the algorithm roots are chosen and a slightly modified version of the graph is used to produce consistent results. See 'details'.} \item{circle2}{The same layout as "tree2", except that afterwards the horizontal levels of the layout are placed in circles.} \item{Other options}{If the assigned value is not in this list it is sent to \code{\link[qgraph]{qgraph}}. This allows for manual specification of the layout as well as using functions found in the 'igraph; library.} } } \item{intercepts}{ Logical, should intercepts be included in the path diagram? } \item{residuals}{ Logical, should residuals (and variances) be included in the path diagram? } \item{thresholds}{ Logical, should thresholds be included in the path diagram? } \item{intStyle}{ Style of the intercepts. \code{"multi"} plots a separate unit vector node for each intercept and \code{"single"} plots a single unit vector node. Currently, \code{"single"} is not well supported and might lead to unexpected results. } \item{rotation}{ An integer indicating the rotation of the layout when "tree" or "tree2" layout is used. 1, 2, 3 and 4 indicate that exogenous variables are placed at the top, left side, bottom and right side respectively. } \item{curve}{ The curvature of the edges. In tree layouts this argument only curves the edges that are between nodes on the same level. e.g., correlations between exogenous manifest variables. } \item{curvature}{Sets the strength of scaling in curvature for curved edges at the same horizontal level in tree layouts. The curve will be set to \code{curve + curvature * n / max(n)}, where \code{n} is the number of nodes in between the two connected nodes.} \item{nCharNodes}{ Number of characters to abbreviate node labels to (using \code{\link[base]{abbreviate}}). Set to 0 to omit abbreviation. } \item{nCharEdges}{ Number of characters to abbreviate edge labels to (using \code{\link[base]{abbreviate}}). Set to 0 to omit abbreviation. } \item{sizeMan}{ Width of the manifest nodes, sent to the 'vsize' argument in \code{\link[qgraph]{qgraph}}. } \item{sizeLat}{ Width of the latent nodes, sent to the 'vsize' argument in \code{\link[qgraph]{qgraph}}. } \item{sizeInt}{ Width of the unit vector nodes, sent to the 'vsize' argument in \code{\link[qgraph]{qgraph}}. } \item{sizeMan2}{ Height of the manifest nodes, sent to the 'vsize2' argument in \code{\link[qgraph]{qgraph}}. } \item{sizeLat2}{ Height of the latent nodes, sent to the 'vsize2' argument in \code{\link[qgraph]{qgraph}}. } \item{sizeInt2}{ Height of the unit vector nodes, sent to the 'vsize2' argument in \code{\link[qgraph]{qgraph}}. } \item{shapeMan}{ Shape of the manifest nodes, sent to the 'shape' argument in \code{\link[qgraph]{qgraph}}. Defaults to \code{"square"} or \code{"rectangle"} if width and height differ. } \item{shapeLat}{ Shape of the latent nodes, sent to the 'shape' argument in \code{\link[qgraph]{qgraph}}. Defaults to \code{"circle"} or \code{"ellipse"} if width and height differ. } \item{shapeInt}{ Shape of the constant nodes, sent to the 'shape' argument in \code{\link[qgraph]{qgraph}}. Defaults to \code{"triangle"}. } \item{ask}{ Specifies the 'ask' parameter in \code{\link[graphics]{par}}. Defaults to TRUE if multiple groups are in the model. } \item{mar}{ Same as the 'mar' argument in \code{\link[qgraph]{qgraph}}. By default this argument is based on the values of 'rotation', 'style' and 'title'. } \item{title}{ Logical, should titles be plotted of the group names above each plot? } \item{title.color}{ Color of the titles. } \item{title.adj}{ Adjustment of title as used by \code{'adj'} in \code{par}. } \item{title.line}{ Line of title as used by \code{'line'} in \code{title}. } \item{title.cex}{ Size of title as used by \code{'cex.main'} in \code{par}. } \item{include}{ Integer vector indicating which groups should be included in the output. e.g., to only plot a diagram for the first group use \code{include = 1}. } \item{combineGroups}{ Logical. If TRUE all groups are combined in the same path diagram. } \item{manifests}{ A character vector in which every element is the name of a manifest variable in the model. This argument can be used to overwrite the order in which nodes are plotted in the graph if \code{reorder = FALSE} } \item{latents}{ A character vector in which every element is the name of a latent variable in the model. This argument can be used to overwrite the order in which nodes are plotted in the graph if \code{reorder = FALSE} } \item{groups}{ Groups nodes that should be colored the same, similar to the 'groups' argument in \code{\link[qgraph]{qgraph}} with a few exceptions. Should be a list containing in each element the names (instead of numbers as in qgraph) of nodes that belong together. Nodes that are indicated to belong to a group will be assigned the same color, as given by the 'color' argument. Nodes not belonging to a group will be assigned the color "", which indicates that they will inherit a mix of the colors of connected nodes (or white, if no connected nodes are colored.) In addition, this argument can be assigned a single character: "manifests", "latents" or "both" to make a single group for each manifest, latent or both manifest and latent variables. e.g., \code{groups = "latents"} will color each latent variable uniquely, and color all manifest variables a mixture of the colors of latents they load on. } \item{color}{ Controls the color of nodes. Similar to 'color' in \code{\link[qgraph]{qgraph}}. A color vector indicating the color for each group, a single color character indicating the color for all nodes or a color vector indicating the color for each node separately. Can also be a list contaning one or more of the following elements (using fuzzy matching): \describe{ \item{man}{The colors for manifest nodes} \item{lat}{The colors for latent nodes} \item{int}{The color for intercepts} } } \item{residScale}{ The size of residual edges if \code{style = "lisrel"}. Defaults to two times the value of 'sizeMan'. } \item{gui}{ Not yet implemented. } \item{allVars}{ Logical. If TRUE all variables are plotted in the path diagrams for each group. If FALSE only variables are plotted that are used in the group. } \item{edge.color}{ A value indicating the color of all edges or a vector indicating the color of each edge. Useful for manually overwriting edge colors. } \item{reorder}{ Logical. Should manifest variables be reordered to be near latent factors they are most connected to in the "tree" layout? If FALSE manifest variables are placed in the order they appear in the Pars. } \item{structural}{ Logical. Set this to TRUE to only show the structural model (omit all manifest variables.) } \item{ThreshAtSide}{ Logical. If TRUE, thresholds are plotted as small lines at the side of manifest nodes, otherwise they are plotted as lines inside the nodes. } \item{thresholdColor}{ Color of the threshold lines. Defaults to "black" } \item{thresholdSize}{ Size of threshold bars relative to the size of the node. } \item{fixedStyle}{ A vector of length one or two specifying the color and line type (same as 'lty' in \code{\link[graphics]{par}}) of fixed parameters. Can be both character and numeric. If one of the elements encodes a color it is used to overwrite the color of fixed edges, and if an element can be coerced to a numeric it is used to encode the line type. For example, \code{ fixedStyle = c("red",3)} specifies that all fixed parameters should be visualized with a red edge with \code{lty=3} } \item{freeStyle}{ Same as 'fixedStyle' but for free parameters instead. } \item{as.expression}{ A character vector indicating which labels should be treated as an \code{\link[base]{expression}}, so that mathematical notation and Greek letters can be used in the path diagram. If this vector contains \code{"nodes"} all node labels are converted to expressions, and if this vector contains \code{"edges"} all node labels are converted to expressions. Defaults to \code{"edges"} only if the input is a Lisrel model. } \item{optimizeLatRes}{ Logical. If this is TRUE, the angle of the incoming residuals on latent variables is attempted to be optimally chosen so its position conflicts with the least amount of connected edges. } \item{inheritColor}{ Logical, should uncolored nodes obtain a mix of connected colored nodes? Defaults to \code{TRUE}. } \item{levels}{A numeric vector usually of length 4. Controls the relative vertical position of variable levels (exogenous and endogenous latents and manifests) under default rotation in tree and circle layouts. This can be used to control the spacing between these levels. e.g., \code{c(1,5,6,7)} will create more space between endogenous manifests and latents.} \item{nodeLabels}{A vector or list to manually overwrite the node labels. Can include expressions.} \item{edgeLabels}{A vector or list to manually overwrite the edge labels. Can include expressions.} \item{pastel}{Logical, should default colors (for groups or edge equality constraints) be chosen from pastel colors? If TRUE then \code{\link[colorspace]{rainbow_hcl}} is used.} \item{rainbowStart}{A number between 0 and 1 indicating the offset used in rainbow functions for default node coloring.} \item{exoVar}{ Should variances of truely exogenous variables (no incomming directed edge) be plotted? Defaults to \code{TRUE} unless \code{style = "lisrel"}. } \item{intAtSide}{ Logical to control if intercepts should be plotted to the side of manifest nodes or at the bottom/top. Defaults only to FALSE if 'residuals=FALSE'. } \item{springLevels}{ Logical indicating if the placement on horizontal levels with \code{tree3} layout should be determined by a force embedded algorithm. } \item{nDigits}{ Number of digits to round numeric values to. } \item{exoCov}{ Should covariances between truely exogenous variables (no incomming directed edge) be plotted? Defaults to \code{TRUE}. } \item{centerLevels}{ Only used if \code{layout} is set to \code{"tree2"}, should each level be centered? Defaults to \code{TRUE} } \item{panelGroups}{ Logical to automatically create a panel plot of multiple group models. Defaults to FALSE. } \item{layoutSplit}{ Logical that can be used to split computing of layout between structural and measurment models. This is very useful in more complicated models where the structural part is best shown by using a spring layout. } \item{measurementLayout}{ Logical indicating the layout algorithm to use for measurement models if \code{layoutSplit = TRUE} (the structural model will obtain a layout given by the \code{layout} argument). } \item{subScale}{ Width of submodels (measurment models) if \code{layoutSplit = TRUE}. } \item{subScale2}{ Height of submodels (measurment models) if \code{layoutSplit = TRUE}. } \item{subRes}{ Integer indicating the resolution of which measurment models can be rotated around their corresponding latent variable. The default, 4, indicates that they can be placed only to polar coordinates. Set to 360 to allow every angle of rotation. } \item{subLinks}{ Vector of variables to link to. Currently not well supported so avoid using this argument. } \item{modelOpts}{ A lists containing arguments sent to \code{\link{semPlotModel}} in case the input is not of class \code{semPlotModel}. } \item{curveAdjacent}{What edges between adjacent horizontal nodes be curved? Can be \code{'<->'} or \code{'cov'} to indicate bidirectional covariances, \code{'->'} or \code{'reg'} for directed regressions or a vector containing both.} \item{edge.label.cex}{Controls the font size of the edge labels. Same as in \code{\link[qgraph]{qgraph}} except that the default is now 0.8.} \item{cardinal}{Should edges in a tree layout connect to the four cardinal points of one of the borders of the node rather than point to the center of the node? Can be set to \code{TRUE} or \code{"all"} to enamble this behavior for all edges and \code{FALSE} or \code{"none"} to disable this behavior for all edges. Alternatively a vector with strings can be specified in which each string specifies a certain group of edges. Fuzzy matching is used on the strings \code{"exo"} for edges with the first node being exogenous (or indicator of exogenous latent), \code{endo} for edges with first node being endogeonous, \code{manifest} for edges connected to any manifest node, \code{latent} for edges connected to any latent node, \code{cov} for covariances, \code{reg} for regressions, \code{load} for factor-loadings, \code{source} for only the start of an edge and \code{end} for only the end of a node. These strings can be combined at will. For example, \code{cardinal = c("exo cov","load end")} (the default) or equivelantly \code{cardinal = c("exogenous covariances","source of loadings")} will only cardenalize the edges that repressent exogenous covariances or the end of factor loadings. } \item{equalizeManifests}{Logical. Should the distances between manifest nodes in the \code{tree1} layout be equalized? Defaults to \code{TRUE}} \item{covAtResiduals}{Logical, should covariances be drawn at the start of residuals when \code{style="lisrel"} is used? Defaults to TRUE.} \item{bifactor}{ A string vector containing the name(s) of the general bifactor(s). This will automatically create a bifactor plot. } \item{optimPoints}{ A vector of radians residuals can optimize to if \code{optimizeLatRes = TRUE} } \item{\dots}{ Arguments sent to the \code{\link[qgraph]{qgraph}} function. These arguments can further control the output of the graph. Some usefull arguments in drawing path diagrams are: \describe{ \item{edge.width}{ Scales the edge width and arrow size of the plot. These can also be manually set using 'esize' and 'asize'. } \item{node.width}{ Scales the width of nodes and also the height if shapes circle and square are used. Can also be a vector with scalar for each node. } \item{node.height}{ Scales the height of nodes. Can also be a vector with scalar for each node. Not used with circle and square shapes. } \item{esize}{Size of the largest edge (or what it would be if there was an edge with weight maximum). Defaults to: max((-1/72)*(nNodes)+5.35,1) for weighted graphs and 2 for unweighted graphs. In directed graphs these values are halved.} \item{asize}{Size of the arrowhead. Defaults to 2 for graphs with more than 10 nodes and 2 to smaller graphs.} \item{minimum}{Edges with absolute weights under this value are omitted. Defaults to 0 for graphs with less than 50 nodes or 0.1 for larger graphs.} \item{maximum}{qgraph regards the highest of the maximum or highest absolute edge weight as the highest weight to scale the edge widths too. To compare several graphs, set this argument to a higher value than any edge weight in the graphs (typically 1 for correlations).} \item{cut}{In weighted graphs, this argument can be used to cut the scaling of edges in width and color saturation. Edges with absolute weights over this value will have the strongest color intensity and become wider the stronger they are, and edges with absolute weights under this value will have the smallest width and become vaguer the weaker the weight. If this is set to NULL, no cutoff is used and all edges vary in width and color. Defaults to NULL for graphs with less then 50 nodes and 0.3 to larger graphs.} \item{details}{Logical indicating if minimum, maximum and cutoff score should be printed under the graph. Defaults to FALSE.} \item{mar}{A vector of the form c(bottom, left, top, right) which gives the margins. Works similar to the argument in par(). Defaults to c(3,3,3,3)} \item{filetype}{A character containing the file type to save the output in. "R" outputs in a new R window, "pdf" creates a pdf file. "svg" creates a svg file (requires RSVGTipsDevice). "tex" creates LaTeX code for the graph (requires tikzDevice). 'jpg', 'tiff' and 'png' can also be used. If this is given any other string (e.g. filetype="") no device is opened. Defaults to 'R' if the current device is the NULL-device or no new device if there already is an open device. A function such as \code{x11} can also be used} \item{filename}{Name of the file without extension} \item{width}{Width of the plot, in inches} \item{height}{Height of the plot, in inches} \item{normalize}{Logical, should the plot be normalized to the plot size. If TRUE (default) border width, vertex size, edge width and arrow sizes are adjusted to look the same for all sizes of the plot, corresponding to what they would look in a 7 by 7 inches plot if normalize is FALSE.} \item{DoNotPlot}{Runs qgraph but does not plot. Useful for saving the output (i.e. layout) without plotting} \item{plot}{Logical. Should a new plot be made? Defaults to TRUE. Set to FALSE to add the graph to the existing plot.} \item{rescale}{Logical. Defines if the layout should be rescaled to fit the -1 to 1 x and y area. Defaults to TRUE. Can best be used in combination with plot=FALSE.} \item{label.cex}{Scalar on the label size.} \item{label.color}{Character containing the color of the labels, defaults to "black"} \item{borders}{Logical indicating if borders should be plotted, defaults to TRUE.} \item{border.color}{Color vector indicating colors of the borders. Is repeated if length is equal to 1. Defaults to "black"} \item{border.width}{Controls the width of the border. Defaults to 2 and is comparable to 'lwd' argument in 'points'.} \item{polygonList}{ A list contaning named lists for each element to include polygons to lookup in the \code{shape} arguments. Each element must be named as they are used in \code{shape} and contain a list with elements \code{x} and \code{y} contaning the coordinates of the polygon. By default \code{ellipse} and \code{heart} are added to this list. These polygons are scaled according to \code{vsize} and \code{vsize2}} \item{vTrans}{Transparency of the nodes, must be an integer between 0 and 255, 255 indicating no transparency. Defaults to 255} \item{label.prop}{Controls the proportion of the width of the node that the label rescales to. Defaults to 0. 9.} \item{label.norm}{A single string that is used to normalize label size. If the width of the label is lower than the width of the hypothetical label given by this argument the width of label given by this argument is used instead. Defaults to "OOO" so that every label up to three characters has the same fontsize.} \item{label.scale}{Logical indicating if labels should be scaled to fit the node. Defaults to TRUE.} \item{label.font}{Integer specifying the label font of nodes. Can be a vector with value for each node} \item{posCol}{Color of positive edges. Can be a vector of two to indicate color of edges under 'cut' value and color of edges over 'cut' value. If 'fade is set to TRUE the first color will be faded the weaker the edge weight is. If this is only one element this color will also be used for edges stronger than the 'cut' value. Defaults to c("#009900","darkgreen")} \item{negCol}{Color of negative edges. Can be a vector of two to indicate color of edges under 'cut' value and color of edges over 'cut' value. If 'fade is set to TRUE the first color will be faded the weaker the edge weight is. If this is only one element this color will also be used for edges stronger than the 'cut' value. Defaults to c("#BF0000","red")} \item{unCol}{Color to indicate the default edge color of unweighted graphs. Defaults to "#808080".} \item{colFactor}{Exponent of transformation in color intensity of relative strength. Defaults to 1 for linear behavior.} \item{trans}{In weighted graphs: logical indicating if the edges should fade to white (FALSE) or become more transparent (TRUE; use this only if you use a background). In directed graphs this is a value between 0 and 1 indicating the level of transparency. (also used as 'transparency')} \item{fade}{if TRUE (default) and if 'edge.color' is assigned, transparency will be added to edges that are not transparent (or for which no transparency has been assigned) relative to the edge strength, similar if 'trans' is set to TRUE.} \item{loop}{This can be used to scale the size of the loop. defaults to 1.} \item{curvePivot}{Quantile to pivot curves on. This can be used to, rather than round edges, make straight edges as curves with "knicks" in them. Can be logical or numeric. \code{FALSE} (default) indicates no pivoting in the curved edges, a number indicates the quantile (and one minus this value as quantile) on which to pivot curved edges and \code{TRUE} indicates a value of 0.1.} \item{curvePivotShape}{The shape of the curve around the pivots, as used in \code{xspline}. Defaults to \code{0.25}.} \item{edge.label.bg}{Either a logical or character vector/matrix. Indicates the background behind edge labels. If TRUE (default) a white background is plotted behind each edge label. If FALSE no background is plotted behind edge labels. Can also be a single color character, a vector or matrix of color vectors for each edge.} \item{edge.label.position}{Vetor of numbers between 0 and 1 controlling the relative position of each edge label. Defaults to 0.5 for placing edge labels at the middle of the edge.} \item{edge.label.font}{Integer specifying the label font of edges. Can be a vector or matrix with value for each node} \item{layout.par}{A list of arguments passed to \code{\link{qgraph.layout.fruchtermanreingold}} when layout="spring" or to an igraph function when such a function is assigned to 'layout'} \item{bg}{If this is TRUE, a background is plotted in which node colors cast a light of that color on a black background. Can also be a character containing the color of the background Defaults to FALSE} \item{bgcontrol}{The higher this is, the less light each node gives if bg=TRUE. Defaults to 6.} \item{bgres}{square root of the number of pixels used in bg=TRUE, defaults to 100.} \item{pty}{See 'par'} \item{font}{Integer specifying the default font for node and edge labels} \item{arrows}{A logical indicating if arrows should be drawn, or a number indicating how much arrows should be drawn on each edge. If this is TRUE, a simple arrow is plotted, if this is a number, arrows are put in the middle of the edges.} \item{arrowAngle}{Angle of the arrowhead, in radians. Defaults to pi/8 for unweighted graphs and pi/4 for weighted graphs.} \item{asize}{Size of the arrowhead. Defaults to 2 for graphs with more than 10 nodes and 2 to smaller graphs.} \item{open}{Logical indicating if open (TRUE) or closed (FALSE) arrowheads should be drawn.} \item{weighted}{Logical that can be used to force either a weighted graph (TRUE) or an unweighted graph(FALSE).} \item{XKCD}{If set to TRUE the graph is plotted in XKCD style based on http://stackoverflow.com/a/12680841/567015.} } } } \details{ The default \code{"tree"} layout under default rotation places the nodes in one of four horizontal levels. At the top the exogenous manifest variables, under that the exogenous latent variables, under that the endogenous latent variables and at the bottom the endogenous manifest variables. If one of these kinds of variables does not exist its level is omitted. Afterwards, the \code{rotation} argument will rotate the graph and the \code{"circle"} layout will make the layout circular using these levels as nested circles. If not manually set (see \code{\link{semPlotModel-edit}}), \code{semPath} will automatically try to set the endogenous and exogenous variables, such that the resulting layout looks good. A latent variable is identified as \emph{exogenous} if it is not on the right hand side of a directed edge (\code{->} or \code{~>}) with another latent variable as node of origin. A manifest variable is set as \emph{exogenous} if it is only connected, in any way, to exogenous latent variables and if it is not the right hand side (dependent variable) of a regression edge (\code{~>}). If all variables are set to exogenous this way, they are all set to endogenous for consistency in the layouts. Afterwards, manifest variables only used in formative measurement models (only outgoing directed edges to latents) are set to exogenous again so that MIMIC models are displayed properly. Intercepts are placed on the same level as the variable, either on the left or right side of the node (pointing outward from the center). Residuals for manifest variables are placed at the top or bottom (for exogenous and endogenous manifests respectively). Residuals of latents are placed at the bottom or top respectively for exogenous and endogenous variables, but is switched if the latent is not connected to a manifest. Residuals for the leftmost and rightmost latent are placed at the left and right side respectively, or diagonal if the latent is connected to an intercept. The \code{"tree2"} and \code{"circle2"} layouts call the \code{layout.reingold.tilford} function from the \code{igraph} package. As roots are used the first available variables of the following list: \itemize{ \item Intercepts of exogenous manifests \item Exogenous manifest \item Intercepts of exogenous latents \item Exogenous latents \item Interceots of endogenous latents \item Endogenous latents \item Intercepts of endogenous manifests \item The endogenous manifest with the most outgoing edges (this should not be possible by default, but can be manually set) \item The most connected endogenous manigest. } To compute an optimal layout \code{layout.reingold.tilford} is run on a slightly altered version of the path diagram. In this version, the direction of edges from all intercepts that are not roots is reversed, the direction of all edges leading to exogenous manifests is reversed and all bidirectional edges are removed. } \value{ A \code{"qgraph"} object as returned by \code{\link[qgraph]{qgraph}}. This object can be used to alter the graph (such as manually redefining the layout) and to plot the graph again with different arguments. If there are multiple groups a list is returned with a "qgraph" object for each path diagram that has been produced. } \references{ Fruchterman, T. & Reingold, E. (1991). Graph drawing by force-directed placement. Software - Pract. Exp. 21, 1129-1164. Reingold, E and Tilford, J (1981). Tidier drawing of trees. IEEE Trans. on Softw. Eng., SE-7(2):223-228. Csardi G, Nepusz T (2006). The igraph software package for complex network research, InterJournal, Complex Systems 1695. http://igraph.sf.net } \author{ Sacha Epskamp } \seealso{ \code{\link[qgraph]{qgraph}} \code{\link{semPlotModel}} \code{\link{semPlotModel-class}} \code{\link{semCors}} \code{\link{lisrelModel}} \code{\link{semSyntax}} } \examples{ # Regression analysis with interaction effects ---------------------------- # A silly dataset: X <- rnorm(100) Y <- rnorm(100) Z <- rnorm(1)*X + rnorm(1)*Y + rnorm(1)*X*Y DF <- data.frame(X,Y,Z) # Regression including interaction: res <- lm(Z ~ X*Y, data = DF) # Path diagram: semPaths(res, intAtSide=TRUE) # Standardized estimates: semPaths(res,"std","hide", intAtSide=TRUE) # Simple CFA ------------------------------------------- library("lavaan") example(cfa) semPaths(fit, 'std', 'est', curveAdjacent = TRUE, style = "lisrel") # MIMIC model ---------------------------------------------------- ## Lavaan \dontrun{ library("lavaan") # Example 5.8 from mplus user guide: Data <- read.table("http://www.statmodel.com/usersguide/chap5/ex5.8.dat") names(Data) <- c(paste("y", 1:6, sep=""), paste("x", 1:3, sep="")) # Model: model.Lavaan <- 'f1 =~ y1 + y2 + y3 f2 =~ y4 + y5 + y6 f1 + f2 ~ x1 + x2 + x3 ' # Run Lavaan: library("lavaan") fit <- lavaan:::cfa(model.Lavaan, data=Data, std.lv=TRUE) # Plot path diagram: semPaths(fit,title=FALSE) # Omit exogenous covariances: semPaths(fit,title=FALSE, exoVar = FALSE, exoCov = FALSE) # Standardized parameters: semPaths(fit,"std", edge.label.cex = 0.5, exoVar = FALSE, exoCov = FALSE) ## Mplus # Same model, now using mplus output: outfile <- tempfile(fileext=".out") download.file("http://www.statmodel.com/usersguide/chap5/ex5.8.html",outfile) # Plot model: semPaths(outfile,intercepts=FALSE) # Note that mplus did not report the fixed variances of the exogenous variables. # Thresholds ----------------------------------------------------- ## Lavaan # Example 5.8 from mplus user guide: Data <- read.table("http://www.statmodel.com/usersguide/chap5/ex5.2.dat") names(Data) <- c("u1","u2","u3","u4","u5","u6") Data <- as.data.frame(lapply(Data, ordered)) # Lavaan model: model <- ' f1 =~ u1 + u2 + u3; f2 =~ u4 + u5 + u6 ' # Run Lavaan: fit <- lavaan::cfa(model, data=Data) # Plot path diagram: semPaths(fit,intercepts=FALSE) ## Mplus # Same model, now using mplus output: outfile <- tempfile(fileext=".out") download.file("http://www.statmodel.com/usersguide/chap5/ex5.2.html",outfile) # Plot model: semPaths(outfile) # OpenMx ---------------------------------------------------------- # To install OpenMx see: # http://openmx.psyc.virginia.edu/ library("OpenMx") # Example from mxRun help page: # Create and run the 1-factor CFA on the openmx.psyc.virginia.edu front page data(demoOneFactor) # load the demoOneFactor dataframe manifests <- names(demoOneFactor) # set the manifest to the 5 demo variables latents <- c("G") # define 1 latent variable model <- mxModel("One Factor", type="RAM", manifestVars = manifests, latentVars = latents, mxPath(from=latents , to=manifests), mxPath(from=manifests, arrows=2), mxPath(from=latents , arrows=2, free=FALSE, values=1.0), mxData(cov(demoOneFactor), type="cov", numObs=500) ) model <- mxRun(model) #run model, returning the result # Plot with colors from OpenMx front page: semPaths(model, color = list( lat = rgb(245, 253, 118, maxColorValue = 255), man = rgb(155, 253, 175, maxColorValue = 255)), mar = c(10, 5, 10, 5)) ## Factor Analysis: source("http://openmx.ssri.psu.edu/docs/OpenMx/latest/_static/demo/TwoFactorModel_PathCov.R") semPaths(twoFactorFit, layout = "tree2") # Multi-group analysis ------------------------------------------- ## LISREL: # Download measurment invariance example: modFile <- tempfile(fileext=".OUT") download.file("http://sachaepskamp.com/files/mi1.OUT",modFile) layout(t(1:2)) semPaths(modFile,"eq",ask=FALSE, intAtSide = TRUE, mar = c(8, 1, 5, 1)) # Color indicates equality constraints. } } semPlot/man/semPlotModel-class.Rd0000644000176200001440000001002214267410262016445 0ustar liggesusers\name{semPlotModel-class} \Rdversion{1.1} \docType{class} \alias{semPlotModel-class} \title{Class \code{"semPlotModel"}} \description{ Representation of SEM models, can be used by \code{\link{semPaths}}, \code{\link{semCors}} and \code{\link{semSyntax}.} See \code{\link{semPlotModel-edit}} for utility functions on how to edit this model. } \section{Objects from the Class}{ Objects can be created by calls of the form \code{new("semPlotModel", ...)}. %% ~~ describe objects here ~~ } \section{Slots}{ \describe{ \item{\code{Pars}:}{Object of class \code{"data.frame"} indicating the parameters used in the SEM model. this must contain the following elements, in order: \describe{ \item{\code{label}}{The name of the parameter, used as edge label in the graph.} \item{\code{lhs}}{Name of the variable on the left hand side of the path.} \item{\code{edge}}{String as indicator of the edge. This can be one of the following: \describe{ \item{\code{->}}{Factor loading} \item{\code{~>}}{Regression. The same as \code{'->'} in that it results in a directed edge from the left hand side to the right hand side, but \code{'~>'} differs in that if the right hand side is manifest and the left hand side is an exogenous latent the right hand side is interpreted as an endogenous variable rather than an exogenous variable.} \item{\code{<->}}{(co)variance} \item{\code{int}}{intercept, The left hand side should be "" and the right hand side indicates the variable to which the intercept belongs.} \item{\code{--}}{Undirected edge. Only used as dummy encoding and in cases the parameter can not be interpreted (usually this indicates something that is not yet supported)} }} \item{\code{rhs}}{Name of the variable on the left hand side of the path.} \item{\code{est}}{Parameter estimate.} \item{\code{est}}{Standardized parameter estimate.} \item{\code{group}}{Character of the name of the group the parameter belongs to.} \item{\code{fixed}}{Logical indicating if the parameter is fixed.} \item{\code{par}}{Parameter number. 0 indicates the parameter is fixed and parameters with the same parameter number are constrained to be equal.} \item{\code{knot}}{Knot number. 0 indicates the edge is not knotted and edges with the same knot number are knotted together. Only used to indicate interactions in 'lm' models and can be omitted.} } } \item{\code{Vars}:}{Object of class \code{"data.frame"} indicating the variables used in the SEM model. Must have the following elements: \describe{ \item{name}{Name of the variable} \item{manifest}{Logical indicating if the variable is manifest} \item{exogenous}{Logical indicating if the variable is exogenous. If \code{NA}} (the default) \code{\link{semPaths}} will attempt to detect which variables are exogenous. }} \item{\code{Thresholds}:}{Object of class \code{"data.frame"} indicating the thresholds in the SEM model. It is the same as \code{Pars} except it does not have the elements \code{'edge'} and \code{'rhs'}.} \item{\code{Computed}:}{Object of class \code{"logical"} indicating if the SEM model was computed or if the object only indicates a structure.} \item{\code{ObsCovs}:}{Object of class \code{"list"} containing observed covariance matrices for each group. If available.} \item{\code{ImpCovs}:}{Object of class \code{"list"} containing implied covariance matrices for each group. If available.} \item{\code{Original}:}{Object of class \code{"list"} containing the original object used as input (or multiple objects if the \code{'+'} operator was used to combine objects.) } } } \section{Methods}{ No methods defined with class "semPlotModel" in the signature. } \author{ Sacha Epskamp } %% ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ \code{\link{semPlotModel}} \code{\link{semPaths}} \code{\link{semCors}} \code{\link{semSyntax}} \code{\link{semPlotModel-edit}} } \examples{ showClass("semPlotModel") } \keyword{classes} semPlot/DESCRIPTION0000644000176200001440000000232514274657172013424 0ustar liggesusersPackage: semPlot Type: Package Title: Path Diagrams and Visual Analysis of Various SEM Packages' Output Version: 1.1.6 Authors@R: c( person("Sacha", "Epskamp", email = "mail@sachaepskamp.com",role = c("aut", "cre")), person("Simon", "Stuber", role = c("ctb")), person("Jason", "Nak", role = c("ctb")), person("Myrthe", "Veenman", role = c("ctb")), person(given = c("Terrence","D."), family = "Jorgensen", role = c("ctb"), comment = c(ORCID = "0000-0001-5111-6773")) ) Maintainer: Sacha Epskamp Depends: R (>= 2.15.0) Suggests: MplusAutomation (>= 0.5-3) Imports: qgraph (>= 1.2.4), lavaan (>= 0.5-11), sem (>= 3.1-0), plyr, XML, igraph (>= 0.6-3), lisrelToR, rockchalk, colorspace, corpcor, methods, OpenMx ByteCompile: yes Description: Path diagrams and visual analysis of various SEM packages' output. URL: https://github.com/SachaEpskamp/semPlot License: GPL-2 LazyLoad: yes NeedsCompilation: no Packaged: 2022-08-10 03:42:52 UTC; sachaepskamp Author: Sacha Epskamp [aut, cre], Simon Stuber [ctb], Jason Nak [ctb], Myrthe Veenman [ctb], Terrence D. Jorgensen [ctb] () Repository: CRAN Date/Publication: 2022-08-10 07:30:02 UTC semPlot/NEWS0000644000176200001440000001530214267413161012402 0ustar liggesusersChanges in Version 1.1.5 o Small change to a link used in an example Changes in Version 1.1.4 o Fixed issues with new lavaan version o Small fix for CRAN Changes in Version 1.1.3 o the 'ramModel' function now supports meanstructure with the 'M' argument. o Fixed an issue with lavaan Changes in Version 1.1.1 o regsem and cv_regsem support added, thanks to Myrthe Veenman and Jason Nak! Changes in Version 1.1 o Fixed a bug with lavaan input o Fixed a bug with OpenMx 2 input o The 'mplusStd' argument of semPlotModel can now be used to specify standardization of mplus models o Fixed a bug related to model constraints o Several updates to accomidate new CRAN checks Changes in Version 1.0.1 o Fixed a dependency related bug causing examples to crash. Changes in Version 1.0.0 New features: o Added the argument 'curveAdjacent' to also curve the covariances between two adjacent nodes as curved edges. o A frequently asked question is how to decrease the font size of edge labels. This can be done via the 'edge.label.cex' argument of the qgraph backend. But because this was not clear the argument now has been added to semPaths as well. The default is slightly smaller than the original qgraph default: 0.6 versus 1. o Added the argument 'cardinal' that controls which edges will be linked to cardinal sides of a node. With this argument the behavior of many path diagram drawing programs can be mirrored. o Added the 'equalizeManifests' argument to equalize the spacing between manifest variables in the 'tree1' layout. o Added the 'covAtResiduals' argument that controls if covariances should be linked to residuals rather than nodes themselves if style="lisrel" o Added the 'bifactor' argument to create bifactor layouts. Only supported with layouts 'tree2', 'tree3', 'circle2' and 'circle3'. o optimizeLatRes has been improved o Added 'optimizePoints' arguments that can be given a vector of radians residuals can optimize to if optimizeLatRes = TRUE. Changes: o The argument curvePivot now defaults to FALSE, causing covariances by default to once again be drawn by circular curved edges. o A list of usefull qgraph arguments that can be used in semPaths is now listed in the semPaths help page. o 'mixCols' renamed to 'inheritColor' o The color argument can now be assined a list for assignng specific colors to all manifests, latents or intercepts o Some improvements to 'semCors' Bug fixes: o Fixed a bug where using style='lisrel' did not correctly curve covariances between latents. o Fixed a bug where 'layoutSplit' resulted in a crash if there were only two connections in the structural model and "spring" layout was used. Changes in Version 0.3.3 o Lavaan model syntax is now supported as input o Numeric edge labels without using whatLabels argument are now correctly abbreviated o Several small fixes Changes in Version 0.3.2 o New features o Matrix model functionality: o Added 'semMatrixAlgebra' to easily perform matrix algebra on any semPlot input object. o Added 'modelMatrices' to obtain model matrices of LISREL, Mplus and RAM modeling frameworks of any input to semPlot. o Added 'exoVar' and 'exoCov' arguments that can be used to not display variances or covariances of truly exogenous variables (no incoming directed edges) o Added 'tree3' and 'circle3' layouts, based on Boker, S. M., McArdle, J. J., & Neale, M. (2002). An algorithm for the hierarchical organization of path diagrams and calculation of components of expected covariance. Structural Equation Modeling, 9(2), 174-194. o Major changes o Added edgeLabels and nodeLabels arguments to manually overwrite edge and node labels, in the order they appear in the RAM and Vars elements of the 'semPlotModel' that is created internally. In addition to the qgraph change that these can now be assigned lists including expressions it should now be easier to add Greek letters. o MplusAutomation is no longer imported but moved to suggests list. This makes sure that the Tcl/Tk interface is not loaded on loading semPlot and as a result makes sure that semPlot does not result in crashes on Mac computers where Tcl/Tk is not installed. o 'style' now defaults to "lisrel" if the input is a Lisrel model. o 'style="lisrel"' will now default exoVar to FALSE. o Changed the name of slot RAM to Pars in semPlotModel class. o Two-level multilevel structures is now supported o Currently this works for Mplus input only. o Only random intercepts are supported, not random slopes. o Thresholds are shown on the within level rather than the between level. o New arguments to semPaths: o Added argument thresholdSize to control the size of threshold bars o Added 'levels' argument. This argument can be used to control the spacing between levels (e.g., exogenous latents) of tree and circle layouts. o Added nDigits argument to control the number of digits used in rounding for labels. o Added 'centerLevels' argument for tree2 layout, to center horizontal levels. o Added 'panelGroups' argument to automatically create a panel plot of multiple group models. o The 'layoutSplit' argument can be used to split computing of layout between structural and measurment models. This is very useful in more complicated models where the structural part is best shown by using a spring layout. o Added the 'intAtSide' argument to control if intercepts should be plotted to the side of manifest nodes or at the bottom/top. Defaults only to FALSE if 'residuals=FALSE'. o Added 'nDigits' argument to control rounding of numeric values. o Minor changes o Thresholds are now plotted via qgraph o Changed argument threshold.color to thresholdColor o 'qgraph' is no longer on the depends list but imported instead. o 'as.expression' now defaults to "edges" if the input is a lisrel model. o 'semPlotModel' for lisrel modes can now use dots to send arguments to 'lisrelModel' o Added 'reduce' argument to lisrelModel that controls if variables that are named the same should be treated as the same variable. o Shape, width and height of manifest, latent and constant variables can now be set. o Mplus input now supports the | operator. o Bug fixes o Fixed a bug where numeric labels where abbreviated, causing erratic behavior on the labels. o Fixed a bug where models with single indicator latent variables caused an error. o Numerous small bugfixes and improvements o Fixed a bug where variable names in mplux models containing BY, WITH or ON caused unexpected behavior. o Assigning a matrix to the layout argument of semPaths will no longer cause a bunch or warnings. Changes in Version 0.3 o First submit to CRAN. semPlot/COPYING0000644000176200001440000004365514267410262012751 0ustar liggesusers GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License.semPlot/R/0000755000176200001440000000000014267410262012102 5ustar liggesuserssemPlot/R/ramModel.R0000644000176200001440000001341614267410262013772 0ustar liggesusers ### SINGLE GROUP MODEL ### ramModel <- function(A,S,F,M,manNames,latNames,Names,ObsCovs,ImpCovs,modelLabels = FALSE) { # Check if meanstructure is included: meanstructure <- !missing(M) # Input matrices either in matrix form or list containing 'est', 'std', ; fixed', and 'par' or 'parSpec' matrices. If 'stdComp' is in the list it overwrites 'std' (compatibility with 'lisrelToR' package): # Or a list of such lists for each group. # Check input, replace matrices with list: mats <- c("A","S","F", "M") for (m in mats) { if (!do.call(missing,list(m))) { assign(m,fixMatrix(get(m))) } else { assign(m,list()) } } ### Fix matrices: matList <- list(A,S,F) Ng <- max(sapply(matList,length)) Nvar <- max(sapply(matList,function(x)sapply(x,function(y)ncol(y$est)))) if (length(F)>0 && !is.null(F[[1]]$est)) { Nman <- max(sapply(F,function(y)nrow(y$est))) } else { if (!missing(manNames)) Nman <- length(manNames) else Nman <- Nvar } if (!missing(manNames) & !missing(latNames)) { if (Nvar!=length(c(manNames,latNames))) stop("Number of variables in model not equal to given number of names") } if (!missing(manNames)) { if (Nman!=length(manNames)) stop("Number of manifest variables in model not equal to given number of names") } # Fix A: if (length(A)==0) { A <- lapply(seq_len(Ng),function(x)list(est=matrix(0,Nvar,Nvar))) } else if (length(A) < Ng) A <- rep(A,length=Ng) # Fix S if (length(S)==0) { S <- lapply(seq_len(Ng),function(x)list(est=matrix(0,Nvar,Nvar))) } else if (length(S) < Ng) S <- rep(S,length=Ng) # Fix F: if (length(F)==0) { F <- lapply(seq_len(Ng),function(x)list(est=cbind(diag(1,Nman,Nman),matrix(0,Nman,Nvar-Nman)))) } else if (length(F) < Ng) F <- rep(F,length=Ng) # Fix M: if (length(M)==0) { M <- lapply(seq_len(Ng),function(x)list(est=rep(0,Nvar))) } else if (length(M) < Ng) M <- rep(M,length=Ng) ### NAMES ### # If names missing, set default:: if (missing(manNames)) { if (length(F)>0 && !is.null(F[[1]]$est)) { if (!is.null(colnames(F[[1]]$est)) && !modelLabels) { manNames <- colnames(F[[1]]$est)[colSums(F[[1]]$est)>0] } else manNames <- paste0(rep("m",Nman),seq_len(Nman)) } else manNames <- paste0(rep("m",Nman),seq_len(Nman)) } if (missing(latNames)) { if (length(F)>0 && !is.null(F[[1]]$est)) { if (!is.null(colnames(F[[1]]$est)) && !modelLabels) { latNames <- colnames(F[[1]]$est)[colSums(F[[1]]$est)==0] } else latNames <- paste0(rep("l",Nvar-Nman),seq_len(Nvar-Nman)) } else latNames <- paste0(rep("l",Nvar-Nman),seq_len(Nvar-Nman)) } if (missing(Names)) { if (length(F)>0 && !is.null(F[[1]]$est)) { if (!is.null(colnames(F[[1]]$est)) && !modelLabels) { Names <- colnames(F[[1]]$est) } else Names <- c(manNames,latNames) } else Names <- c(manNames,latNames) } Parss <- list() dumPars <- data.frame( label = character(0), lhs = character(0), edge = character(0), rhs = character(0), est = numeric(0), std = numeric(0), group = character(0), fixed = logical(0), par = numeric(0), stringsAsFactors=FALSE) if (missing(ImpCovs)) { modCovs <- list() } for (g in 1:Ng) { # Compute model implied covariance matrix and standardized matrices: # M is matrix list: Mod <- list(A=A[[g]]$est, S=S[[g]]$est, F=F[[g]]$est) IminAinv <- InvEmp(diag(1,nrow(Mod$A),ncol(Mod$A)) - Mod$A) if (missing(ImpCovs)) { modCovs[[g]] <- with(Mod, F %*% IminAinv %*% S %*% t(IminAinv) %*% t(F)) rownames(modCovs[[g]]) <- colnames(modCovs[[g]]) <- manNames } Mstd <- Mod ## Standardize matrices I <- diag(nrow(Mod$S)) expCov <- IminAinv %*% Mod$S %*% t(IminAinv) invSDs <- 1/sqrt(diag(expCov)) diag(I) <- invSDs # standardize the A, S and M matrices # A paths are value*sd(from)/sd(to) = I %*% A %*% solve(I) # S paths are value/(sd(from*sd(to))) = I %*% S %*% I Mstd$A <- I %*% Mod$A %*% solve(I) Mstd$S <- I %*% Mod$S %*% I # Store matrices: if (length(A) > 0 && !is.null(A[[g]]$est) && is.null(A[[g]]$std)) A[[g]]$std <- Mstd$A if (length(S) > 0 && !is.null(S[[g]]$est) && is.null(S[[g]]$std)) S[[g]]$std <- Mstd$S # Extract matrices: if (length(A)>0) APars <- modMat2Pars(A[[g]],"->","A",symmetric=FALSE,vec=FALSE,Names,Names,group=paste("Group",g),exprsup="") else APars <- dumPars if (length(S)>0) SPars <- modMat2Pars(S[[g]],"<->","S",symmetric=TRUE,vec=FALSE,Names,Names,group=paste("Group",g),exprsup="") else SPars <- dumPars if (length(M)>0) MPars <- modMat2Pars(M[[g]],"int","M",symmetric=FALSE,vec=TRUE,"",Names,group=paste("Group",g),exprsup="") else Mpars <- dumPars # Combine ParsS: Parss[[g]] <- rbind(APars,SPars,MPars) # Remove zeroes: Parss[[g]] <- Parss[[g]][Parss[[g]]$est!=0,] } Pars <- do.call(rbind,Parss) # Variable dataframe: Vars <- data.frame( name = c(manNames,latNames), manifest = c(manNames,latNames)%in%manNames, exogenous = NA, stringsAsFactors=FALSE) # Remove duplicates plus factor loadings betwen mans and lats of same name: Vars <- Vars[!duplicated(Vars$name),] Pars <- Pars[!(Pars$lhs==Pars$rhs&Pars$edge!="<->"),] semModel <- new("semPlotModel") semModel@Pars <- Pars semModel@Vars <- Vars semModel@Original <- list() if (!missing(ObsCovs)) { semModel@ObsCovs <- list(ObsCovs) } else { semModel@ObsCovs <- list() } if (!missing(ImpCovs)) { semModel@ImpCovs <- list(ImpCovs) } else { semModel@ImpCovs <- modCovs } semModel@Computed <- length(semModel@ImpCovs) > 0 return(semModel) } semPlot/R/semPaths.R0000644000176200001440000017556514267410262014034 0ustar liggesusers# Arguments: # rotation: 1 = normal (endo manifests under), 2 3 and 4 flip counterclockwise. # 2 = endo manifests righy # 3 = endo man up # 4 = endo man left # allVars: TRUE includes variables that are not in model (e.g. with between-within group models) # Layout modes: # "tree" # "circle" # "spring" # igraph function # "tree2" and "circle2" for layout.reingold.tilford # Boker # manifests: vector of manifest labels ordered # latents: vector of latents ordered # fixedStyle: if coercible to numeric lty is assigned this value, else a color for color representation. If this argument is not a number or color representation the edge is not displayed differently. semPaths <- function(object,what="paths",whatLabels,style,layout="tree",intercepts=TRUE,residuals=TRUE,thresholds=TRUE, intStyle="multi",rotation=1,curve, curvature = 1, nCharNodes=3,nCharEdges=3,sizeMan = 5,sizeLat = 8, sizeInt = 2, sizeMan2 ,sizeLat2 ,sizeInt2, shapeMan, shapeLat, shapeInt = "triangle", ask,mar,title,title.color="black", title.adj = 0.1, title.line = -1, title.cex = 0.8, include,combineGroups=FALSE,manifests,latents,groups,color, residScale,gui=FALSE,allVars=FALSE,edge.color, reorder=TRUE,structural=FALSE,ThreshAtSide=FALSE,thresholdColor,thresholdSize = 0.5, fixedStyle=2,freeStyle=1, as.expression=character(0),optimizeLatRes=FALSE,inheritColor=TRUE,levels,nodeLabels,edgeLabels, pastel=FALSE,rainbowStart=0,intAtSide,springLevels=FALSE,nDigits=2,exoVar,exoCov=TRUE,centerLevels=TRUE, panelGroups=FALSE,layoutSplit = FALSE, measurementLayout = "tree", subScale, subScale2, subRes = 4, subLinks, modelOpts = list(mplusStd="std"), curveAdjacent = "<->", edge.label.cex = 0.6, cardinal = "none", equalizeManifests = FALSE, covAtResiduals = TRUE, bifactor, optimPoints = 1:8 * (pi/4), ...){ # c("exo cov","load dest","endo man cov") # Check if input is combination of models: call <- paste(deparse(substitute(object)), collapse = "") if (grepl("\\+",call)) { args <- unlist(strsplit(call,split="\\+")) obs <- lapply(args,function(x)semPlotModel(eval(parse(text=x)))) object <- obs[[1]] for (i in 2:length(obs)) object <- object + obs[[i]] } if (!"semPlotModel"%in%class(object)) object <- do.call(semPlotModel,c(list(object),modelOpts)) stopifnot("semPlotModel"%in%class(object)) # if (gui) return(do.call(semPathsGUI,as.list(match.call())[-1])) ### edgeConnectPoints dummy: ECP <- NULL # Set defaults size and shape: if (missing(sizeMan2)) sizeMan2 <- sizeMan if (missing(sizeLat2)) sizeLat2 <- sizeLat if (missing(sizeInt2)) sizeInt2 <- sizeInt if (missing(shapeMan)) { if (sizeMan == sizeMan2) shapeMan <- "square" else shapeMan <- "rectangle" } if (missing(shapeLat)) { if (sizeLat == sizeLat2) shapeLat <- "circle" else shapeLat <- "ellipse" } # Check: if (missing(intAtSide)) intAtSide <- !residuals if (!rotation%in%1:4) { stop("Rotation must be 1, 2 3 or 4.") } if (any(object@Pars$edge=="int")) { object@Vars$name[object@Vars$name=="1"] <- "_1" object@Pars$lhs[object@Pars$lhs=="1"] <- "_1" object@Pars$rhs[object@Pars$rhs=="1"] <- "_1" } # Check if layout is not character of length 1. If so, set layout <- "spring" as dummy: if (!is.character(layout) || length(layout) > 1) { layoutFun <- layout layout <- "spring" } else layoutFun <- NULL if (!missing(bifactor) & !layout %in% c("tree2","tree3","circle2","circle3")) { warning("'bifactor' argument only supported in layouts 'tree2', 'tree3', 'circle2' and 'circle3'") } if (missing(curve)) { if (layout %in% c("tree","tree2","tree3")) { curve <- 1 } else { curve <- 0 } } curveDefault <- curve # if (missing(curvePivot)) # { # curvePivot <- grepl("tree",layout) # } if (missing(whatLabels)) { edge.labels <- TRUE } else { edge.labels <- FALSE } if (missing(as.expression)) { if ("lisrel" %in% unlist(sapply(object@Original,class))) { as.expression <- "edges" } else as.expression <- "" } # Set and check style: if (missing(style)) { if ("lisrel" %in% unlist(sapply(object@Original,class))) { style <- "lisrel" } else style <- "OpenMx" } if (grepl("ram",style,ignore.case=TRUE)) style <- "OpenMx" if (!grepl("mx|lisrel",style,ignore.case=TRUE)) stop("Only OpenMx (ram) or LISREL style is currently supported.") # if (grepl("mx",style,ignore.case=TRUE) & !missing(residScale)) warning("'residScale' ingored in OpenMx style") if (missing(residScale)) residScale <- sizeMan # Set exoVar default: if (missing(exoVar)) exoVar <- !grepl("lis",style,ignore.case=TRUE) # residScale <- residScale * 1.75 # Remove means if means==FALSE if (intercepts==FALSE) { object@Pars <- object@Pars[object@Pars$edge!="int",] } # Set true exogenous: object@Vars$trueExo <- !object@Vars$name %in% object@Pars$rhs[object@Pars$edge %in% c("->","~>")] # Remove true exo variances: if (!exoVar) { object@Pars <- object@Pars[!((object@Pars$lhs %in% object@Vars$name[object@Vars$trueExo] | object@Pars$rhs %in% object@Vars$name[object@Vars$trueExo]) & object@Pars$edge == "<->" & (object@Pars$rhs == object@Pars$lhs)), ] } if (!exoCov) { object@Pars <- object@Pars[!((object@Pars$lhs %in% object@Vars$name[object@Vars$trueExo] | object@Pars$rhs %in% object@Vars$name[object@Vars$trueExo]) & object@Pars$edge == "<->" & (object@Pars$rhs != object@Pars$lhs)), ] } # Remove residuals if residuals=FALSE if (residuals==FALSE) { object@Pars <- object@Pars[!(object@Pars$edge=="<->"&object@Pars$lhs==object@Pars$rhs),] } # Combine groups if combineGroups=TRUE: if (combineGroups) { object@Pars$group <- "" } # Within - Between framework: if (is.null(object@Pars$BetweenWithin)) { object@Pars$BetweenWithin <- '' if (nrow(object@Thresholds) > 0) { object@Thresholds$BetweenWithin <- '' } } if ((length(unique(object@Pars$BetweenWithin)) > 1 && !all(unique(object@Pars$BetweenWithin) %in% c('Within','Between'))) | length(unique(object@Pars$BetweenWithin)) > 2) stop("BetweenWithin must be labeled 'Between' and 'Within' only") if (length(unique(object@Pars$BetweenWithin)) == 2) { object@Pars$group <- paste(object@Pars$group,'-',object@Pars$BetweenWithin) object@Pars$group <- gsub('\\s+\\-\\s+(?=Within$)','',object@Pars$group,perl=TRUE) object@Pars$group <- gsub('\\s+\\-\\s+(?=Between$)','',object@Pars$group,perl=TRUE) if (nrow(object@Thresholds) > 0) { object@Thresholds$group <- paste(object@Thresholds$group,'-',object@Thresholds$BetweenWithin) object@Thresholds$group <- gsub('\\s+\\-\\s+(?=Within$)','',object@Thresholds$BetweenWithin,perl=TRUE) object@Thresholds$group <- gsub('\\s+\\-\\s+(?=Between$)','',object@Thresholds$BetweenWithin,perl=TRUE) } } # Set title: if (missing(title)) { # Check titles: title <- length(unique(object@Pars$group))>1 } # If structural, remove all manifest from Pars: if (structural) { object@Pars <- object@Pars[!(object@Pars$lhs %in% object@Vars$name[object@Vars$manifest] | object@Pars$rhs %in% object@Vars$name[object@Vars$manifest]),] object@Vars <- object@Vars[!object@Vars$manifest,] object@Thresholds <- data.frame() } # Add rows for bidirectional edges: if (any(object@Pars$edge=="<->" & object@Pars$lhs != object@Pars$rhs)) { bidirs <- object@Pars[object@Pars$edge=="<->" & object@Pars$lhs != object@Pars$rhs,] bidirs[c("lhs","rhs")] <- bidirs[c("rhs","lhs")] bidirs$par <- -1 object@Pars <- rbind(object@Pars,bidirs) } object@Pars <- object@Pars[!duplicated(object@Pars),] # Extract names: manNames <- object@Vars$name[object@Vars$manifest] if (!missing(manifests)) { if (!(all(manNames%in%manifests) & length(manifests) == length(manNames))) { stop(paste("Argument 'manifests' should be a vector containing reordered elements of the vector",dput(manNames))) } manNames <- manifests } latNames <- object@Vars$name[!object@Vars$manifest] if (!missing(latents)) { if (!(all(latNames%in%latents) & length(latents) == length(latNames))) { stop(paste("Argument 'latents' should be a vector containing reordered elements of the vector",dput(latNames))) } latNames <- latents } Labels <- c(manNames,latNames) nM <- length(manNames) nL <- length(latNames) nN <- length(Labels) object@Vars <- object@Vars[match(Labels,object@Vars$name),] # Define groups and colors setup: DefaultColor <- FALSE if (!missing(groups)) { if (is.character(groups)) { if (any(grepl("man",groups,ignore.case=TRUE)) & any(grepl("lat",groups,ignore.case=TRUE))) { groups <- as.list(c(manNames,latNames)) } else if (any(grepl("man",groups,ignore.case=TRUE)) & !any(grepl("lat",groups,ignore.case=TRUE))) { groups <- as.list(manNames) } else if (!any(grepl("man",groups,ignore.case=TRUE)) & any(grepl("lat",groups,ignore.case=TRUE))) { groups <- as.list(latNames) } else stop("Character specification of 'groups' must contain 'man','lat' or both") } if (is.factor(groups) | is.character(groups)) groups <- tapply(1:length(groups),groups,identity) if (!is.list(groups)) stop("'groups' argument is not a factor or list") if (missing(color)) { if (pastel) { if (length(groups) == 1) color <- "white" else color <- rainbow_hcl(length(groups), start = rainbowStart * 360, end = (360 * rainbowStart + 360*(length(groups)-1)/length(groups))) } else { if (length(groups) == 1) color <- "white" else color <- rainbow(length(groups), start = rainbowStart, end = (rainbowStart + (max(1,length(groups)-1))/length(groups)) %% 1) } } } else { if (missing(color)) { color <- "background" } } # # Define exogenous variables (only if any is NA): # if (any(is.na(object@Vars$exogenous))) # { # if (any(!is.na(object@Vars$exogenous))) # { # exoOrig <- object@Vars$exogenous # repExo <- TRUE # } else repExo <- FALSE # object@Vars$exogenous <- FALSE # for (i in which(!object@Vars$manifest)) # { # if (!any(object@Pars$edge[object@Pars$rhs==object@Vars$name[i]] %in% c("~>","->") & object@Pars$lhs[object@Pars$rhs==object@Vars$name[i]]%in%latNames)) # { # object@Vars$exogenous[i] <- TRUE # } # } # for (i in which(object@Vars$manifest)) # { # if (all(object@Pars$lhs[object@Pars$rhs==object@Vars$name[i] & object@Pars$lhs%in%latNames]%in%object@Vars$name[object@Vars$exogenous]) & # all(object@Pars$rhs[object@Pars$lhs==object@Vars$name[i] & object@Pars$rhs%in%latNames]%in%object@Vars$name[object@Vars$exogenous]) & # !any(object@Pars$rhs==object@Vars$name[i] & object@Pars$edge=="~>")) # { # object@Vars$exogenous[i] <- TRUE # } # } # # # If all exo, treat all as endo: # if (all(object@Vars$exogenous) | layout%in%c("circle","circle2","circle3")) # { # object@Vars$exogenous <- FALSE # } # # If al endo, treat formative manifest as exo (MIMIC mode), unless all manifest are formative. # if (!any(object@Vars$exogenous)) # { # if (any(object@Vars$manifest & (object@Vars$name%in%object@Pars$rhs[object@Pars$edge %in% c("~>","--","->")]))) # object@Vars$exogenous[object@Vars$manifest & !(object@Vars$name%in%object@Pars$rhs[object@Pars$edge %in% c("~>","--","->")])] <- TRUE # } # if (repExo) # { # object@Vars$exogenous[!is.na(exoOrig)] <- exoOrig[!is.na(exoOrig)] # } # } object <- defExo(object, layout) Groups <- unique(object@Pars$group) qgraphRes <- list() if (missing(ask)) { if (length(Groups)>1) ask <- TRUE else ask <- FALSE } askOrig <- par("ask") if (missing(include)) include <- 1:length(Groups) if (panelGroups) { layout(t(1:length(include))) } # Reassign labels (temporary solution for excluding vars in multi group) AllLabs <- Labels AllMan <- manNames AllLat <- latNames par(ask=ask) ### If no sub, set sub to 0 (root sub) if (is.null(object@Pars$sub)) { if (!layoutSplit) { object@Pars$sub <- 0 } else { object@Pars$sub <- 1 ### Detect manifest children of each latent: for (i in seq_along(latNames)) { # Connected manifests: object@Pars$sub[object@Pars$lhs == latNames[i] & object@Pars$rhs%in%manNames & object@Pars$edge%in%c('->','~>')] <- i+1 # Intercepts and variances connected to these manifests: object@Pars$sub[object@Pars$rhs%in%object@Pars$rhs[object@Pars$rhs%in%manNames & object@Pars$sub==(i+1)] & object@Pars$edge == "int"] <- i+1 object@Pars$sub[object@Pars$rhs%in%object@Pars$rhs[object@Pars$rhs%in%manNames & object@Pars$sub==(i+1)] & object@Pars$lhs%in%object@Pars$rhs[object@Pars$rhs%in%manNames & object@Pars$sub==(i+1)] & object@Pars$edge == "<->"] <- i+1 } # Remove manifests already in a submodel from model 1: ManInSub <- manNames[ manNames %in% object@Pars$lhs[object@Pars$sub > 1] | manNames %in% object@Pars$rhs[object@Pars$sub > 1]] object@Pars$sub[ (object@Pars$lhs %in% ManInSub | object@Pars$rhs %in% ManInSub) & object@Pars$sub == 1] <- 0 } } if (missing( subLinks)) { subLinks <- latNames } if (missing(subScale)) { subScale <- 0.1 + 0.3 * (1 / max(1,max(object@Pars$sub))) } if (missing(subScale2)) { subScale2 <- subScale * 1.5 } layoutMain <- layout rotationMain <- rotation for (gr in Groups[(1:length(Groups))%in%include]) { grSub <- object@Pars$sub[object@Pars$group==gr] if (length(unique(grSub)) == 1) grSub[] <- 0 # List to store results (layout and curve of submodel 1 - n, 1 being root) subModList <- list() # Start sub loop (one loop per sub and once for whole graph, if number of subs is 1 ignore) # -1 is rerun for main graph: for (Sub in (max(grSub):0)[max(grSub):0%in%c(grSub,0)]) { if (Sub > 0) { GroupPars <- object@Pars[object@Pars$group==gr & object@Pars$sub==Sub,] GroupVars <- object@Vars GroupThresh <- object@Thresholds[object@Thresholds$group==gr & object@Pars$sub==Sub,] } else { GroupPars <- object@Pars[object@Pars$group==gr,] GroupVars <- object@Vars GroupThresh <- object@Thresholds[object@Thresholds$group==gr,] } if (Sub > 1) { GroupVars$exogenous <- FALSE rotation <- 1 layout <- measurementLayout } else { rotation <- rotationMain layout <- layoutMain } # Restore Labels, manNames and latNames: Labels <- AllLabs manNames <- AllMan latNames <- AllLat nM <- length(AllMan) nL <- length(AllLat) ### Reorder nodes in order of factors if (reorder) { ConOrd <- function(nodes) { E <- GroupPars[c("lhs","rhs")] subE <- rbind(as.matrix(E[E[,1]%in%nodes,1:2]),as.matrix(E[E[,2]%in%nodes,2:1])) subE <- subE[subE[,2]%in%GroupVars$name[!GroupVars$manifest],,drop=FALSE] ranks <- rank(match(subE[,2],GroupVars$name)) # ranks <- match(subE[,2],object@Vars$name) avgCon <- sapply(nodes,function(x)mean(ranks[subE[,1]==x])) return(order(avgCon)) } # Endo: EnM <- which(GroupVars$manifest & !GroupVars$exogenous) if (length(EnM) > 0) { GroupVars[EnM,] <- GroupVars[EnM,][ConOrd(GroupVars$name[EnM]),] } rm(EnM) ExM <- which(GroupVars$manifest & GroupVars$exogenous) # Exo: if (length(ExM) > 0) { GroupVars[ExM,] <- GroupVars[ExM,][ConOrd(GroupVars$name[ExM]),] } rm(ExM) manNames <- GroupVars$name[GroupVars$manifest] Labels <- c(manNames,latNames) } Ni <- sum(GroupPars$edge=="int") # Add intercept: if (any(object@Pars$edge=="int")) { Labels[Labels=="1"] <- "_1" if (intStyle == "single") { Labels <- c(Labels,"1") } else if (intStyle == "multi") { Labels <- c(Labels,rep("1",Ni)) } } nN <- length(Labels) # Extract edgelist: Edgelist <- GroupPars[c("lhs","rhs")] Edgelist$lhs <- match(Edgelist$lhs,Labels) Edgelist$lhs[GroupPars$edge=="int"] <- (nM+nL+1):nN Edgelist$rhs <- match(Edgelist$rhs,Labels) # Coerce to numeric matrix: Edgelist$lhs <- as.numeric(Edgelist$lhs) Edgelist$rhs <- as.numeric(Edgelist$rhs) Edgelist <- as.matrix(Edgelist) if (!allVars) { NodesInGroup <- sort(unique(c(Edgelist[,1],Edgelist[,2]))) incl <- 1:nN %in% NodesInGroup Edgelist[,1] <- match(Edgelist[,1],NodesInGroup) Edgelist[,2] <- match(Edgelist[,2],NodesInGroup) } else incl <- 1:nN Labels <- Labels[incl] nN <- length(Labels) nM <- sum(manNames%in%Labels) nL <- sum(latNames%in%Labels) GroupVars <- GroupVars[GroupVars$name%in%Labels,] manInts <- Edgelist[GroupPars$edge=="int" & GroupPars$rhs%in%manNames,,drop=FALSE] latInts <- Edgelist[GroupPars$edge=="int" & GroupPars$rhs%in%latNames,,drop=FALSE] manIntsEndo <- manInts[!GroupVars$exogenous[manInts[,2]],,drop=FALSE] manIntsExo <- manInts[GroupVars$exogenous[manInts[,2]],,drop=FALSE] latIntsEndo <- latInts[!GroupVars$exogenous[latInts[,2]],,drop=FALSE] latIntsExo <- latInts[GroupVars$exogenous[latInts[,2]],,drop=FALSE] endoMan <- which(Labels%in%manNames&Labels%in%GroupVars$name[!GroupVars$exogenous]) exoMan <- which(Labels%in%manNames&Labels%in%GroupVars$name[GroupVars$exogenous]) endoLat <- which(Labels%in%latNames&Labels%in%GroupVars$name[!GroupVars$exogenous]) exoLat <- which(Labels%in%latNames&Labels%in%GroupVars$name[GroupVars$exogenous]) # Bidirectional: Bidir <- GroupPars$edge == "<->" if (!grepl("mx",style,ignore.case=TRUE)) { Bidir[GroupPars$lhs==GroupPars$rhs] <- FALSE } # Shape: Shape <- c(rep(shapeMan,nM),rep(shapeLat,nL)) if (any(GroupPars$edge=="int")) Shape <- c(Shape,rep(shapeInt,Ni)) Curve <- curve # Layout: if (layout=="tree" | layout=="circle" | layout=="circular") { # if (all(!object@Vars$exogenous)) # { if (intStyle=="single") { # Curves: Curve <- ifelse(GroupPars$lhs != GroupPars$rhs & ((GroupPars$lhs%in%manNames & GroupPars$rhs%in%manNames) | (GroupPars$lhs%in%latNames & GroupPars$rhs%in%latNames)),curve,NA) Curve <- ifelse(GroupPars$lhs%in%manNames,Curve,-1*Curve) Curve <- ifelse(GroupPars$edge=="int" & GroupPars$rhs%in%latNames,curve,-1*Curve) # Empty layout: Layout <- matrix(,length(Labels),2) # Add vertical levels: Layout[,2] <- ifelse(Labels%in%manNames,1,2) # Add vertical levels: Layout[Labels%in%manNames,1] <- seq(-1,1,length=nM) if (any(GroupPars$edge=="int")) { sq <- seq(-1,1,length=nL+1) cent <- floor(median(1:(nL+1))) Layout[!Labels%in%manNames,1] <- sq[c(which(1:(nL+1) < cent),which(1:(nL+1) > cent),cent)] } else { Layout[Labels%in%latNames,1] <- seq(-1,1,length=nL) } } else if (intStyle=="multi") { # Empty layout: Layout <- matrix(,length(Labels),2) # Add vertical levels: Layout[endoMan,2] <- 1 Layout[endoLat,2] <- 2 Layout[exoLat,2] <- 3 Layout[exoMan,2] <- 4 Layout[latIntsEndo[,1],2] <- 2 Layout[latIntsExo[,1],2] <- 3 if (intAtSide) { Layout[manIntsExo[,1],2] <- 4 Layout[manIntsEndo[,1],2] <- 1 } else { Layout[manIntsExo[,1],2] <- 5 Layout[manIntsEndo[,1],2] <- 0 } # Add horizontal levels: if (nrow(manIntsEndo)>0) { Layout <- mixInts(endoMan,manIntsEndo,Layout,intAtSide=intAtSide) } else { if (length(endoMan)==1) Layout[endoMan,1] <- 0 else Layout[endoMan,1] <- seq(-1,1,length=length(endoMan)) } if (nrow(manIntsExo)>0) { Layout <- mixInts(exoMan,manIntsExo,Layout,intAtSide=intAtSide) } else { if (length(exoMan)==1) Layout[exoMan,1] <- 0 else Layout[exoMan,1] <- seq(-1,1,length=length(exoMan)) } if (nrow(latIntsEndo)>0) { Layout <- mixInts(endoLat,latIntsEndo,Layout,trim=TRUE) } else { Layout[endoLat,1] <- seq(-1,1,length=length(endoLat)+2)[-c(1,length(endoLat)+2)] } if (nrow(latIntsExo)>0) { Layout <- mixInts(exoLat,latIntsExo,Layout,trim=TRUE) } else { Layout[exoLat,1] <- seq(-1,1,length=length(exoLat)+2)[-c(1,length(exoLat)+2)] } if (equalizeManifests) { # Max of number of nodes in lvls 1 and 4: EndoHorRange <- max(sapply(c(0,1,4,5), function(x) sum(Layout[,2] == x))) for (lvl in c(0,1,4,5)) Layout[Layout[,2]==lvl,1] <- sum(Layout[,2]==lvl) * Layout[Layout[,2]==lvl,1] / EndoHorRange } } else stop("MeanStyle not supported") # Optimize layout if reorder = TRUE } else if (layout %in% c("tree2","circle2")) { # reingold-tilford layout # Layout <- layout.reingold.tilford # Set roots, in order of precedence: # exo man intercepts (incomming edges on exo man reversed) # Any exo man with outward edges (incomming edges on exo man reversed) # All exo man # Exo latent intercept # Exo latentes # Endo latent intercept # Endo latents # Manifest intercepts # Endo man with most outgoing edges # Endo man with least incoming edges # For all roots, base graph on graph with: # Double headed arrows removed # Arrow on other intercepts reversed # # if (any(GroupPars$lhs %in% GroupVars$name[exoMan] & GroupPars$edge %in% c("->","~>"))) # { # roots <- sort(unique(Edgelist[,1][which(GroupPars$lhs %in% GroupVars$name[exoMan] & GroupPars$edge %in% c("->","~>"))])) # if (any(roots %in% manIntsExo[,2])) # { # roots <- manIntsExo[match(roots,manIntsExo[,2]),1] # } # } else # # If bifactor is assigned and exists, bifactor becomes root and all edges not connected to bifactor are reversed: if (!missing(bifactor) && any(bifactor %in% Labels)) { roots <- which(Labels %in% bifactor) } else { if (nrow(manIntsExo) > 0) { roots <- manIntsExo[,1] } else if (length(exoMan) > 0) { roots <- exoMan } else if (nrow(latIntsExo) > 0) { roots <- latIntsExo[,1] } else if (length(exoLat) > 0) { roots <- exoLat } else if (nrow(latIntsEndo) > 0) { roots <- latIntsEndo[,1] } else if (length(endoLat) > 0) { roots <- endoLat } else if (nrow(rbind(manIntsExo,manIntsEndo)) > 0) { roots <- rbind(manIntsExo,manIntsEndo)[,1] } else if (any(GroupPars$edge %in% c("->","~>"))) { roots <- Mode(Edgelist[,1][GroupPars$edge %in% c("->","~>")]) } else { roots <- Mode(c(Edgelist[,1],Edgelist[,2])) } } Layout <- rtLayout(roots,GroupPars,Edgelist,layout,exoMan) # Fix top level to use entire range: # Layout[Layout[,2]==max(Layout[,2]),1] <- seq(min(Layout[,1]),max(Layout[,1]),length.out=sum(Layout[,2]==max(Layout[,2]))) # Center all horizontal levels: # if (centerLevels) if (length(roots)>1) Layout[,1] <- ave(Layout[,1],Layout[,2],FUN = function(x) scale(x,TRUE,FALSE)) if (centerLevels) Layout[,1] <- ave(Layout[,1],Layout[,2],FUN = function(x) scale(x,TRUE,FALSE)) } else if (layout%in%c("tree3","circle3")) { # Igraph: # Select only directed edges: Edgelist2 <- Edgelist[GroupPars$edge%in%c("->","~>"),] # Flip edges connected to manifest indicators of exogenous latents: Edgelist2[Edgelist2[,2]%in%which(GroupVars$manifest&GroupVars$exogenous),] <- Edgelist2[Edgelist2[,2]%in%which(GroupVars$manifest&GroupVars$exogenous),2:1] # Flip all edges that are not connected to the bifactor: if (!missing(bifactor) && any(bifactor %in% Labels)) { Edgelist2[!Labels[Edgelist2[,1]] %in% bifactor & !Labels[Edgelist2[,2]] %in% bifactor,1:2] <- Edgelist2[!Labels[Edgelist2[,1]] %in% bifactor & !Labels[Edgelist2[,2]] %in% bifactor,2:1] } iG <- graph.edgelist(Edgelist2) sp <- shortest.paths(iG,mode="out") sp[!is.finite(sp)] <- 0 maxPaths <- apply(sp,1,max) # Mix in intercepts: if (any(GroupPars$edge=="int")) { maxPathsInts <- maxPaths[Edgelist[GroupPars$edge=="int",2]] if (!intAtSide) { maxPathsInts[maxPathsInts==min(maxPaths)] <- min(maxPaths) - 1 maxPathsInts[maxPathsInts==max(maxPaths)] <- max(maxPaths) + 1 } maxPaths <- c(maxPaths,maxPathsInts) } if (springLevels) { Cons <- cbind(NA,maxPaths) Layout <- qgraph.layout.fruchtermanreingold(Edgelist,vcount=length(maxPaths),constraints=Cons*sqrt(length(maxPaths))) } else { Layout <- cbind(NA,maxPaths) Layout[,1] <- ave(Layout[,2],Layout[,2],FUN=function(x)seq(-1,1,length=length(x)+2)[-c(1,length(x)+2)]) # Mix intercepts: if (any(GroupPars$edge=="int")) { intMap <- rbind(manInts,latInts) for (i in sort(unique(Layout[,2]))) { if (any(which(Layout[,2]==i)%in%intMap[,1])) { conInts <- which(Layout[,2]==i) conInts <- conInts[conInts%in%intMap[,1]] Layout <- mixInts(intMap[intMap[,1]%in%conInts,2],intMap,Layout,trim=TRUE,intAtSide=intAtSide) } } } } } else Layout <- layout # loopRotation: if (layout%in%c("tree","tree2","tree3")) { loopRotation <- rep(0,nN) loopRotation[endoMan] <- pi loopRotation[exoMan] <- 0 loopRotation[endoLat] <- 0 noCons <- sapply(endoLat,function(x)nrow(Edgelist[(Edgelist[,1]==x|Edgelist[,2]==x) & (Edgelist[,1]%in%endoMan|Edgelist[,2]%in%endoMan),,drop=FALSE])==0) if (length(noCons)==0) noCons <- logical(0) loopRotation[endoLat][noCons] <- pi if (length(endoLat) > 1 & !(length(exoLat)==0&length(exoMan)==0)) { if (length(exoLat) > 0 | any(endoLat %in% latIntsEndo[,2])) { loopRotation[endoLat[which.min(Layout[endoLat,1])]] <- ifelse(noCons[which.min(Layout[endoLat,1])],5/4*pi,7/4*pi) loopRotation[endoLat[which.max(Layout[endoLat,1])]] <- ifelse(noCons[which.min(Layout[endoLat,1])],3/4*pi,1/4*pi) } else { loopRotation[endoLat[which.min(Layout[endoLat,1])]] <- 6/4 * pi loopRotation[endoLat[which.max(Layout[endoLat,1])]] <- 2/4 * pi } } else if (length(endoLat) == 1 && endoLat %in% latIntsEndo[,2]) { loopRotation[endoLat] <- 6/4 * pi } loopRotation[exoLat] <- pi noCons <- sapply(exoLat,function(x)nrow(Edgelist[(Edgelist[,1]==x|Edgelist[,2]==x) & (Edgelist[,1]%in%exoMan|Edgelist[,2]%in%exoMan),,drop=FALSE])==0) if (length(noCons)==0) noCons <- logical(0) loopRotation[exoLat][noCons] <- 0 if (length(exoLat) > 1 & length(exoMan)>0) { if (length(endoLat) > 0 | any(exoLat %in% latIntsExo[,2])) { loopRotation[exoLat[which.min(Layout[exoLat,1])]] <- ifelse(noCons[which.min(Layout[exoLat,1])],7/4*pi,5/4*pi) loopRotation[exoLat[which.max(Layout[exoLat,1])]] <- ifelse(noCons[which.min(Layout[exoLat,1])],1/4*pi,3/4*pi) } else { loopRotation[exoLat[which.min(Layout[exoLat,1])]] <- 6/4*pi loopRotation[exoLat[which.max(Layout[exoLat,1])]] <- 2/4*pi } } else if (length(exoLat) == 1 && exoLat %in% latIntsExo[,2]) { loopRotation[exoLat] <- 6/4 * pi } if (any(GroupVars$exogenous) & optimizeLatRes) { ### For latents that have loops, find a nice angle: for (i in which(Labels%in%latNames & Labels%in%GroupPars$lhs[GroupPars$lhs==GroupPars$rhs])) { # Layout subset of all connected: subEdgelist <- Edgelist[(Edgelist[,1]==i|Edgelist[,2]==i)&(Edgelist[,1]!=Edgelist[,2]),,drop=FALSE] conNodes <- c(subEdgelist[subEdgelist[,1]==i,2],subEdgelist[subEdgelist[,2]==i,1]) # Test for empty: if (nrow(subEdgelist)==0) conNodes <- sort(unique(c(Edgelist[,1:2]))) subLayout <- Layout[conNodes,,drop=FALSE] # Add degree of edges passing node: lower <- which(Layout[,2] < Layout[i,2]) higher <- which( Layout[,2] > Layout[i,2]) passNode <- which((Edgelist[,1] %in% lower & Edgelist[,2] %in% higher) | (Edgelist[,2] %in% lower & Edgelist[,1] %in% higher)) if (length(passNode) > 0) { passLayout <- do.call(rbind,lapply(passNode, function(ii)c(mean(Layout[Edgelist[ii,],1]), mean(Layout[Edgelist[ii,],2])))) subLayout <- rbind(subLayout, passLayout) } Degrees <- apply(subLayout,1,function(x)atan2(x[1]-Layout[i,1],x[2]-Layout[i,2])) loopRotation[i] <- optimPoints[which.max(sapply(optimPoints,loopOptim,Degrees=Degrees))] # Completely forgot point of this whole thing here: # if (!grepl("lisrel",style,ignore.case=TRUE) | !any((Edgelist[,1]==i|Edgelist[,2]==i)&(Edgelist[,1]!=Edgelist[,2])&GroupPars$edge=="<->")) # { # # loopRotation[i] <- optimize(loopOptim,c(0,2*pi),Degrees=Degrees,maximum=TRUE)$maximum # loopRotation[i] <- optimPoints[which.max(sapply(optimPoints,loopOptim,c(0,2*pi),Degrees=Degrees))] # } else { # # Layout subset of all connected: # subEdgelist <- Edgelist[(Edgelist[,1]==i|Edgelist[,2]==i)&(Edgelist[,1]!=Edgelist[,2])&GroupPars$edge=="<->",] # conNodes <- c(subEdgelist[subEdgelist[,1]==i,2],subEdgelist[subEdgelist[,2]==i,1]) # # # Test for empty: # if (nrow(subEdgelist)==0) conNodes <- sort(unique(c(Edgelist[,1:2]))) # # subLayout <- Layout[conNodes,] # goodDegrees <- apply(subLayout,1,function(x)atan2(x[1]-Layout[i,1],x[2]-Layout[i,2])) # loopRotation[i] <- optimize(loopOptim,c(min(goodDegrees-pi/4),max(goodDegrees+pi/4)),Degrees=Degrees,maximum=TRUE)$maximum # } } } # } else if (layout=="tree3"|layout=="circle3") # { # loopRotation <- rep(NA,nN) # loopRotation[endoMan] <- pi # loopRotation[exoMan] <- 0 } else loopRotation <- rep(NA, length(Labels)) ### ORDINALIZE LAYOUT ### if (layout=="tree") { Layout[Layout[,2]>0&Layout[,2]<5,2] <- as.numeric(as.factor(Layout[Layout[,2]>0&Layout[,2]<5,2])) Layout[Layout[,2]==0,2] <- (1*!residuals) * 0.25 Layout[Layout[,2]==5,2] <- max(Layout[Layout[,2]<5,2]) + (1 - (1*!residuals)*0.25) } # Level layout: if (!missing(levels)&layout%in%c("tree","tree2","tree3","circle","circle2","circle3")) { if (length(levels) min(Layout[x,1]) & Layout[Layout[,2]==Layout[x[1],2],1] < max(Layout[x,1]))) } # Curves: inBet <- apply(Edgelist,1,inBetween) inBet[inBet>0] <- as.numeric(as.factor(inBet[inBet>0])) # if (!grepl("lisrel",style,ignore.case=TRUE) | all(!GroupVars$exogenous) | !residuals) # { if (isTRUE(curveAdjacent)) { percurveAdjacent <- rep(TRUE,nrow(Edgelist)) } else { percurveAdjacent <- rep(FALSE,nrow(Edgelist)) curveAdjacent <- gsub("<->","cov",curveAdjacent) curveAdjacent <- gsub("(->)|(~>)","reg",curveAdjacent) if (is.character(curveAdjacent)) { percurveAdjacent[(any(grepl("reg",curveAdjacent,ignore.case=TRUE))&GroupPars$edge%in%c("->","~>",ignore.case=TRUE))|(any(grepl("cov",curveAdjacent))&GroupPars$edge%in%c("<->"))] <- TRUE } } # Original curve: Curve <- ifelse(Layout[Edgelist[,1],2]==Layout[Edgelist[,2],2]&Edgelist[,1]!=Edgelist[,2]&GroupPars$edge!="int",ifelse(inBet<(1-percurveAdjacent),0,curve+curvature*(inBet)/max(1,max(inBet))*curve),NA) # Curve <- ifelse(Layout[Edgelist[,1],2]==Layout[Edgelist[,2],2]&Edgelist[,1]!=Edgelist[,2]&GroupPars$edge!="int",ifelse(inBet<(1-percurveAdjacent),0,curve),NA) # } else { # Curve <- ifelse(Layout[Edgelist[,1],2]==Layout[Edgelist[,2],2]&Edgelist[,1]!=Edgelist[,2]&GroupPars$edge!="int" & Labels[Edgelist[,1]]%in%manNames & Labels[Edgelist[,2]]%in%manNames,ifelse(inBet<1,0,curve+inBet/max(inBet)*curve),NA) # } ### If origin node is "right" of destination node, flip curve: Curve[Layout[Edgelist[,1],1] > Layout[Edgelist[,2],1]] <- -1 * Curve[Layout[Edgelist[,1],1] > Layout[Edgelist[,2],1]] ## If endo man, flip again: Curve <- ifelse(Edgelist[,1]%in%endoMan | Edgelist[,2]%in%endoMan, -1 * Curve, Curve) ### Cardinal options: # Fuzzy matching: # exo/endo # man/lat # cov/reg/load # start/end if (any(grepl("all",cardinal)) || isTRUE(cardinal)) cardinal <- "exo endo man lat cov reg load source dest" ### Edge connect points: if (length(cardinal) > 0 && !identical(cardinal,FALSE) && !all(grepl("none",cardinal))) { if (packageDescription("qgraph")$Version == "1.2.3") warning("'cardinal' argument requires qgraph version 1.2.4") ECP <- matrix(NA,nrow(Edgelist),2) lvlDiff <- Layout[Edgelist[,1],2] - Layout[Edgelist[,2],2] ECP[lvlDiff>0,1] <- pi ECP[lvlDiff>0,2] <- 0 ECP[lvlDiff<0,1] <- 0 ECP[lvlDiff<0,2] <- pi ECP[lvlDiff==0,1] <- ifelse(Curve!=0, ifelse((loopRotation[Edgelist[,1]]+0.5*pi)%%2*pi <= pi, pi, 0), NA)[lvlDiff==0] ECP[lvlDiff==0,2] <- ifelse(Curve!=0, ifelse((loopRotation[Edgelist[,1]]+0.5*pi)%%2*pi <= pi, pi, 0), NA)[lvlDiff==0] ECP <- (ECP - 0.5 * (rotation-1) * pi ) %% (2*pi) # All nonspecified to NA: allSelect <- matrix(FALSE,nrow(ECP),2) for (cardGroup in cardinal) { select <- matrix(grepl("(exo)|(endo)|(man)|(lat)|(cov)|(reg)|(load)|(src)|(source)|(dest)",cardGroup),nrow(ECP),2) if (grepl("(endo)|(exo)",cardGroup)) { # First node first / endo: select <- select & ((grepl("endo",cardGroup,ignore.case=TRUE) & !GroupVars$trueExo[Edgelist[,1]]) | (grepl("exo",cardGroup,ignore.case=TRUE) & GroupVars$trueExo[Edgelist[,1]] ) ) } if (grepl("(lat)|(man)",cardGroup)) { # Any node man / latent select <- select & ((grepl("lat",cardGroup,ignore.case=TRUE) & (!GroupVars$manifest[Edgelist[,1]] | !GroupVars$manifest[Edgelist[,2]])) | (grepl("man",cardGroup,ignore.case=TRUE) & (GroupVars$manifest[Edgelist[,1]] | GroupVars$manifest[Edgelist[,2]]) ) ) } if (grepl("(cov)|(reg)|(load)",cardGroup)) { # Edge is cov/reg/loading: select <- select & ((grepl("cov",cardGroup,ignore.case=TRUE) & (GroupPars$edge=="<->")) | (grepl("reg",cardGroup,ignore.case=TRUE) & (GroupPars$edge%in%c("->","~>") & !(!GroupVars$manifest[Edgelist[,1]] & GroupVars$manifest[Edgelist[,2]]))) | (grepl("load",cardGroup,ignore.case=TRUE) & (GroupPars$edge%in%c("->","~>") & (!GroupVars$manifest[Edgelist[,1]] & GroupVars$manifest[Edgelist[,2]])) ) ) } if (grepl("(src)|(source)|(dest)",cardGroup)) { # Start/end: select[,1] <- select[,1] & grepl("(src)|(source)",cardGroup,ignore.case=TRUE) select[,2] <- select[,2] & grepl("dest",cardGroup,ignore.case=TRUE) } allSelect[select] <- TRUE } ECP[!allSelect] <- NA } ### Flip ECP, loopRotation and curve for any non bifactor variables, if specified: if (!missing(bifactor) && any(bifactor %in% Labels) && layout %in% c("tree2", "tree3", "circle2", "circle3")) { loopRotation[!Labels %in% bifactor] <- loopRotation[!Labels %in% bifactor] + pi ECP[!GroupPars$lhs%in%bifactor,1] <- ECP[!GroupPars$lhs%in%bifactor,1] + pi ECP[!GroupPars$lhs%in%bifactor,2] <- ECP[!GroupPars$lhs%in%bifactor,2] + pi Curve[!GroupPars$lhs%in%bifactor & !GroupPars$lhs%in%bifactor] <- -1 * Curve[!GroupPars$lhs%in%bifactor & !GroupPars$lhs%in%bifactor] } ### Rotate loopRotation: loopRotation <- loopRotation - 0.5 * (rotation-1) *pi # for (i in unique(Layout[,2])) # { # Layout[Layout[,2]==i,1] <- (as.numeric(as.factor(Layout[Layout[,2]==i,1])) - 1) / (sum(Layout[,2]==i) - 1) # } # FLIP LAYOUT ### if (rotation==2) { Layout <- Layout[,2:1] Layout[,1] <- -1 * Layout[,1] } if (rotation==3) { Layout[,1] <- -1 * Layout[,1] Layout[,2] <- -1 * Layout[,2] } if (rotation==4) { Layout <- Layout[,2:1] Layout[,2] <- -1 * Layout[,2] } Layout[,2] <- Layout[,2]-max(Layout[,2]) + 0.5 } ### ROTATE IF CIRCLE: if (layout%in%c("circle","circle2","circle3")) { if (rotation%in%c(2,4)) stop("Circle layout only supported if rotation is 1 or 3") underMean <- Layout[,2] < mean(Layout[,2]) Layout[,2] <- -1*Layout[,2] + max(Layout[,2]) + 0.5 Ltemp <- Layout unVert <- sort(unique(Layout[,2])) for (i in unVert) { l <- sum(Layout[,2]==i) sq <- seq(0,2*pi,length=l+1)[-(l+1)] + pi/l c <- 1 for (j in order(Layout[Layout[,2]==i,1])) { Ltemp[which(Layout[,2]==i)[j],] <- c(RotMat(sq[c])%*%c(0,i)) c <- c + 1 } } Layout <- Ltemp # loopRotation: loopRotation <- apply(Layout,1,function(x)atan2(x[1],x[2])) loopRotation <- ifelse(underMean,loopRotation,(loopRotation+pi)%%(2*pi)) } if (layout == "spring") loopRotation <- rep(NA, length(Labels)) if (layoutSplit & length(unique(grSub)) > 1 & Sub > 0) { if (is.character(Layout)) { Layout <- qgraph(Edgelist, layout = Layout, DoNotPlot = TRUE, edgelist=TRUE)$layout } ## Store in submodel list (could well be moved earlier but whatever) subModList[[Sub]] <- list( Layout = Layout, loopRotation = loopRotation, Curve = Curve, Labels = Labels, ECP = ECP ) } } ### COMBINE SUB MODELS ### if (layoutSplit & length(unique(grSub)) > 1 & length(subModList) > 1) { ### Rescale subScale to height in width relative to diameter of device in inches ### din <- par("din") diamet <- sqrt(sum(din^2)) subDim <- diamet * c(subScale, subScale2) if (is.character(Layout)) { Layout <- qgraph(Edgelist, layout = Layout, DoNotPlot = TRUE)$layout } # Rescale main layout: Layout <- LayoutScaler(Layout, din[1]/2, din[2]/2) subModList[[1]]$Layout <- LayoutScaler(subModList[[1]]$Layout) # Angle from center: centAngles <- atan2(subModList[[1]]$Layout[,1],subModList[[1]]$Layout[,2]) + pi subModList[[1]]$Layout <- LayoutScaler(subModList[[1]]$Layout, din[1]/2, din[2]/2) centAngles[subModList[[1]]$Layout[,1]==0&subModList[[1]]$Layout[,2]==0] <- mean(centAngles[!(subModList[[1]]$Layout[,1]==0&subModList[[1]]$Layout[,2]==0)]) + pi if (layout %in% c('tree','tree2','tree3')) { err <- 1.1 } else { err <- 1.1 } srot <- ifelse(rotation%in%c(1,3),1/err,err) centAngles <- atan2(srot*sin(centAngles),cos(centAngles)) if (subRes != 0) { centAngles <- round_any(centAngles%%(2*pi), (2*pi)/subRes) } # Rescale and rotate sub layouts and enter in main layout: for (g in rev(seq_along(subModList))) { if (g > 1 && !is.null(subModList[[g]])) { link <- c(which(subModList[[1]]$Labels == subLinks[g-1]), which(subModList[[g]]$Labels == subLinks[g-1]) ) # Scale: # subDim2 <- abs(c(RotMat(centAngles[link[1]]) %*% subDim)) # subDim2 <- subDim2 / abs(c(RotMat(centAngles[link[1]]) %*% rev(din))) # subModList[[g]]$Layout <- LayoutScaler(subModList[[g]]$Layout, c(-1,1) * subDim[1]/2, c(-1,1) * subDim[2]/2) # Map to inch coordinates: subModList[[g]]$Layout <- LayoutScaler(subModList[[g]]$Layout, subDim[1]/2, subDim[2]/2) # Center to link: subModList[[g]]$Layout[,1] <- subModList[[g]]$Layout[,1] - subModList[[g]]$Layout[link[2],1] subModList[[g]]$Layout[,2] <- subModList[[g]]$Layout[,2] - subModList[[g]]$Layout[link[2],2] # Rotate: subModList[[g]]$Layout <- t(RotMat(centAngles[link[1]]) %*% t(subModList[[g]]$Layout)) # Map back to usr coordinates: # subModList[[g]]$Layout[,1] <- subModList[[g]]$Layout[,1] / (din[1]/2) # subModList[[g]]$Layout[,2] <- subModList[[g]]$Layout[,2] / (din[2]/2) # Center to Layout: subModList[[g]]$Layout[,1] <- subModList[[g]]$Layout[,1] + subModList[[1]]$Layout[link[1],1] subModList[[g]]$Layout[,2] <- subModList[[g]]$Layout[,2] + subModList[[1]]$Layout[link[1],2] } # Enter in general model: subLabnums <- match(subModList[[g]]$Labels[subModList[[g]]$Labels!='1'],Labels) subLabnums <- c(subLabnums,manInts[match(match(GroupPars$rhs[GroupPars$sub==g & GroupPars$edge == "int" & GroupPars$rhs %in% manNames],Labels),manInts[,2]),1]) subLabnums <- c(subLabnums,latInts[match(match(GroupPars$rhs[GroupPars$sub==g & GroupPars$edge == "int" & GroupPars$rhs %in% latNames],Labels),latInts[,2]),1]) Layout[subLabnums,] <- subModList[[g]]$Layout Curve[GroupPars$sub == g] <- subModList[[g]]$Curve if (g == 1) { loopRotation[subLabnums] <- subModList[[g]]$loopRotation ECP[object@Pars$sub == g & object@Pars$group == gr,] <- subModList[[g]]$ECP for (g2 in length(subModList):2) { if (!is.null(subModList[[g2]])) { loopRotation[Labels==latNames[g2-1]] <- centAngles[g2-1] # ECP[object@Pars$sub == g,] <- centAngles[g2-1] } } } else { loopRotation[subLabnums] <- (subModList[[g]]$loopRotation + centAngles[link[1]]) %% ( 2*pi) ECP[object@Pars$sub == g & object@Pars$group == gr,] <- (subModList[[g]]$ECP + centAngles[link[1]]) %% ( 2*pi) # ECP <- (subModList[[g]]$ECP + centAngles[link[1]]) %% ( 2*pi) } } } # Edge labels: if (edge.labels) { eLabels <- GroupPars$label } else eLabels <- rep("",nrow(Edgelist)) # vsize: vSize <- numeric(nN) vSize[Labels%in%manNames] <- sizeMan vSize[Labels%in%latNames] <- sizeLat vSize[Labels=="1"] <- sizeInt vSize2 <- numeric(nN) vSize2[Labels%in%manNames] <- sizeMan2 vSize2[Labels%in%latNames] <- sizeLat2 vSize2[Labels=="1"] <- sizeInt2 eColor <- rep(NA,nrow(Edgelist)) # tColor <- rep(rgb(0.5,0.5,0.5),nrow(GroupThresh)) if (missing(thresholdColor)) { tColor <- rep("border", nN) } else { tColor <- rep(thresholdColor, nN) } ### WHAT TO PLOT? ### if (grepl("path|diagram|mod",what,ignore.case=TRUE)) { } else if (grepl("stand|std",what,ignore.case=TRUE)) { Edgelist <- cbind(Edgelist,GroupPars$std) if (edge.labels) eLabels <- GroupPars$std } else if (grepl("est|par",what,ignore.case=TRUE)) { Edgelist <- cbind(Edgelist,GroupPars$est) if (edge.labels) eLabels <- GroupPars$est } else if (grepl("eq|cons",what,ignore.case=TRUE)) { # eColor <- rep(rgb(0.5,0.5,0.5),nrow(Edgelist)) unPar <- unique(object@Pars$par[object@Pars$par>0 & duplicated(object@Pars$par)]) if (pastel) { cols <- rainbow_hcl(max(c(object@Pars$par,GroupThresh$par)), c = 35, l = 85) } else { cols <- rainbow(max(c(object@Pars$par,GroupThresh$par))) } for (i in unPar) { eColor[GroupPars$par==i] <- cols[i] } if (nrow(GroupThresh) > 0) { warning("Equality constraints of Thresholds currently not supported") # for (i in 1:nrow(GroupThresh)) # { # if (GroupThresh$par[i]>0 & sum(GroupThresh$par[i] == object@Thresholds$par) > 1 ) # { # tColor[i] <- cols[GroupThresh$par[i]] # } # } } } else if (!grepl("col",what,ignore.case=TRUE)) stop("Could not detect use of 'what' argument") ### VERTEX COLOR ### # Set default if list: if (is.list(color)) { colList <- color color <- rep("",nN) if (!is.null(colList$man)) { color[Labels%in%manNames] <- colList$man } if (!is.null(colList$lat)) { color[Labels%in%latNames] <- colList$lat } if (!is.null(colList$int)) { color[Labels=="1"] <- colList$int } } if (!missing(groups)) { NodeGroups <- groups Ng <- length(NodeGroups) if (length(color)==1) { Vcolors <- rep(color,nN) } else if (length(color)==nM) { Vcolors <- c(color,rep("",nN-nM)) } else if (length(color)==nN) { Vcolors <- color } else if (length(color)!=Ng) { stop("'color' vector not of appropriate length") } if (missing(manifests) & any(sapply(NodeGroups,mode)!="character")) warning("Groups specified numerically and 'manifests' not supplied. Results might be unexpected.") if (length(color)==Ng) { Vcolors <- rep("",nN) for (g in 1:Ng) { if (mode(NodeGroups[[g]])=="character") { ### hier grepl! NodeGroups[[g]] <- matchVar(NodeGroups[[g]], GroupVars, manIntsExo, manIntsEndo, latIntsExo, latIntsEndo) # NodeGroups[[g]] <- match(NodeGroups[[g]],Labels) } Vcolors[NodeGroups[[g]]] <- color[g] } # Vcolors[Vcolors=="" & Labels%in%manNames] <- "white" } } else { NodeGroups <- NULL if (length(color)==1) { Vcolors <- rep(color,nN) } else if (length(color)==nM) { Vcolors <- c(color,rep(NA,nN-nM)) } else if (length(color)==nN) { Vcolors <- color } else stop("'color' vector not of appropriate length") } # If missing color, obtain weighted mix of connected colors: if (any(Vcolors=="")) { if (inheritColor) { VcolorsBU <- Vcolors W <- 1 # for (i in 1:(nM+nL)) for (i in 1:nN) { if (Vcolors[i]=="") { cons <- c(Edgelist[Edgelist[,1]==i,2],Edgelist[Edgelist[,2]==i,1]) if (ncol(Edgelist) == 3) { W <- abs(c(Edgelist[Edgelist[,1]==i,3],Edgelist[Edgelist[,2]==i,3])) W <- W[VcolorsBU[cons]!=""] } cons <- cons[VcolorsBU[cons]!=""] if (length(cons)>0) { Vcolors[i] <- mixColfun(VcolorsBU[cons],W) } else Vcolors[i] <- NA } } } Vcolors[Vcolors==""] <- NA } if (grepl("col",what,ignore.case=TRUE)) { # eColor <- character(nrow(Edgelist)) for (i in 1:nrow(Edgelist)) { cols <- Vcolors[Edgelist[i,]] if (!all(cols=="background")) eColor[i] <- mixColfun(cols[cols!="background"]) } } if (!missing(whatLabels)) { if (grepl("path|diagram|model|name|label",whatLabels,ignore.case=TRUE)) { eLabels <- GroupPars$label } else if (grepl("stand|std",whatLabels,ignore.case=TRUE)) { eLabels <- GroupPars$std } else if (grepl("est|par",whatLabels,ignore.case=TRUE)) { eLabels <- GroupPars$est } else if (grepl("eq|cons",whatLabels,ignore.case=TRUE)) { eLabels <- GroupPars$par } else if (grepl("no|omit|hide|invisible",whatLabels,ignore.case=TRUE)) { eLabels <- rep("",nrow(Edgelist)) } else stop("Could not detect use of 'whatLabels' argument") } # Abbreviate: if (!"edges"%in%as.expression) { if (is.numeric(eLabels)) { eLabels <- ifelse(is.na(eLabels),"",formatC(eLabels, format=ifelse(all(eLabels%%1==0),'d','f'), digits=nDigits)) } else { if (nCharEdges>0) eLabels <- abbreviate(eLabels,nCharEdges) } } if (!"nodes"%in%as.expression) { if (is.numeric(Labels)) { Labels <- ifelse(is.na(Labels),"",formatC(Labels, format=ifelse(all(Labels%%1==0),'d','f'), digits=nDigits)) } else { if (nCharNodes>0 ) Labels <- abbreviate(Labels,nCharNodes) } } # ### CONVERT TO LISREL STYLE ### if (grepl("lisrel",style,ignore.case=TRUE) & residuals & covAtResiduals) { isResid <- GroupPars$edge == "<->" & GroupPars$lhs != GroupPars$rhs & (GroupPars$lhs %in% GroupPars$lhs[GroupPars$edge == "<->" & GroupPars$lhs == GroupPars$rhs] & GroupPars$rhs %in% GroupPars$rhs[GroupPars$edge == "<->" & GroupPars$lhs == GroupPars$rhs]) } else isResid <- rep(FALSE,nrow(Edgelist)) # nResid <- length(whichResid) # Edgelist[whichResid,1] <- (nN+1):(nN+nResid) # rots <- loopRotation[Edgelist[whichResid,2]] # Lresid <- matrix(,nResid,2) # hLength <- diff(range(Layout[,1])) # vLength <- diff(range(Layout[,2])) # for (i in 1:nResid) # { # Lresid[i,1] <- Layout[Edgelist[whichResid[i],2],1] + sin(rots[i]) * residScale * 0.25 * hLength/vLength # Lresid[i,2] <- Layout[Edgelist[whichResid[i],2],2] + cos(rots[i]) * residScale * 0.25 # } # # # Add nodes: # Layout <- rbind(Layout,Lresid) # Labels <- c(Labels,rep("",nResid)) # Shape <- c(Shape,rep("circle",nResid)) # loopRotation <- NULL # vSize <- c(vSize,rep(0,nResid)) # Vcolors <- c(Vcolors,rep(rgb(0,0,0,0),nResid)) # } if (grepl("mx",style,ignore.case=TRUE)) LoopAsResid <- FALSE else LoopAsResid <- TRUE if (!allVars) { NodeGroups2 <- NodeGroups if (!is.null(NodeGroups2)) { newNodes <- match(1:length(AllLabs),(1:length(AllLabs))[incl]) for (g in 1:length(NodeGroups2)) { NodeGroups2[[g]] <- newNodes[NodeGroups2[[g]]] NodeGroups2[[g]] <- NodeGroups2[[g]][!is.na(NodeGroups2[[g]])] } } } ### Compute margins ### if (missing(mar)) { if (!layoutSplit) { Mar <- c(5,5,5,5) # Add 3 to top and bottom for residuals if lisrel style is used: if (grepl("lisrel",style,ignore.case=TRUE)) Mar[c(1,3)] <- Mar[c(1,3)] + 3 # # Add 4 to bottom if there are endo man residual correlations: # if (any(Edgelist[,1]%in%endoMan & Edgelist[,2]%in%endoMan & Edgelist[,1]!=Edgelist[,2])) # { # Mar[1] <- Mar[1] + 4 # } # # # Add 4 to top if there are endo man residual correlations: # if (any(Edgelist[,1]%in%exoMan & Edgelist[,2]%in%exoMan & Edgelist[,1]!=Edgelist[,2])) # { # Mar[3] <- Mar[3] + 4 # } # # Add 3 to top if top consist of latent residuals: # if (length(exoMan)==0) # { # Mar[3] <- Mar[3] + 3 # } # Rotate: Mar <- Mar[(0:3 + (rotation-1)) %% 4 + 1] # Add 2 to top for title: if (title) Mar[3] <- Mar[3] + 2 } else { Mar <- c(3,3,3,3) } } else Mar <- mar # Overwrite edge colors if appropriate: if (!missing(edge.color)) { eColor <- edge.color if (thresholds & missing(thresholdColor)) { tColor <- rep(edge.color,length(tColor)) } } # Fixed and free edges: if (length(freeStyle) > 2 | length(fixedStyle) > 2) warning("'freeStyle' and 'fixedStyle' are assumed to be vectors of at most length 2. Unexpected results will probably occur.") # lty: lty <- rep(1,nrow(GroupPars)) # fixedStyle if (any(is.numeric(fixedStyle) | grepl("^\\d+$",fixedStyle))) lty <- ifelse(GroupPars$fixed,as.numeric(fixedStyle[is.numeric(fixedStyle) | grepl("^\\d+$",fixedStyle)]),lty) if (any(isColor(fixedStyle) & !(is.numeric(fixedStyle) | grepl("^\\d+$",fixedStyle)))) eColor[GroupPars$fixed] <- fixedStyle[isColor(fixedStyle) & !(is.numeric(fixedStyle) | grepl("^\\d+$",fixedStyle))] # freeStyle: if (any(is.numeric(freeStyle) | grepl("\\d+",freeStyle))) lty <- ifelse(GroupPars$fixed,lty,as.numeric(freeStyle[is.numeric(freeStyle) | grepl("\\d+",freeStyle)])) if (any(isColor(freeStyle) & !(is.numeric(freeStyle) | grepl("\\d+",freeStyle)))) eColor[!GroupPars$fixed] <- freeStyle[isColor(freeStyle) & !(is.numeric(freeStyle) | grepl("\\d+",freeStyle))] # Directed settings: Directed <- GroupPars$edge!="--" # Convert labels to expressions: if ("edges"%in%as.expression) { eLabels <- lapply(eLabels,function(x)if (x=="") x else as.expression(parse(text=x))) } # Convert labels to expressions: if ("nodes"%in%as.expression) { Labels <- lapply(Labels,function(x)if (x=="") x else as.expression(parse(text=x))) } # Restore layout function: if (!is.null(layoutFun)) Layout <- layoutFun # Overwrite node and edge labels: if (!missing(nodeLabels)) { nLab <- nodeLabels[object@Vars$name %in% GroupVars$name] } else nLab <- Labels # Overwrite node and edge labels: if (!missing(edgeLabels)) { eLab <- edgeLabels[object@Pars$group==gr] } else eLab <- eLabels ### WITHIN - BETWEEN FRAMEWORK ### CircleEdgeEnd <- rep(FALSE, nrow(Edgelist)) if (any(c('Between','Within')%in%GroupPars$BetweenWithin)) { if (all(GroupPars$BetweenWithin == 'Within')) { # WITHIN CLUSTER SETUP BetweenPars <- object@Pars[object@Pars$group == gsub("Within$","Between",gr),] # BetweenInts <- BetweenPars$rhs[BetweenPars$edge == 'int'] BetweenVars <- unique(c(BetweenPars$lhs,BetweenPars$rhs)) CircleEdgeEnd[GroupPars$rhs %in% BetweenVars & GroupPars$edge %in% c('->','~>')] <- TRUE } else if (all(GroupPars$BetweenWithin == 'Between')) { # BETWEEN CLUSTER SETUP WithinPars <- object@Pars[object@Pars$group == gsub("Between$","Within",gr),] WithinVars <- unique(c(WithinPars$lhs,WithinPars$rhs)) Shape[Labels %in% WithinVars ] <- shapeLat } else stop("BetweenWithin not only 'Between' or 'Within'.") } ### Threshold setup ### bars <- list() length(bars) <- nN barSide <- rep(1, nN) if (thresholds) { if (missing(thresholdColor) & missing(edge.color)) { tColor <- rep("border", nN) } if (nrow(GroupThresh) > 0) { for (node in unique(match(GroupThresh$lhs,GroupVars$name))) { # node <- which(Labels==GroupThresh$lhs[i]) # Compute side: IntSide <- 1 if (layout=="tree") { if (rotation%in%c(1,3)) { barSide[node] <- ifelse(Layout[node,2]>mean(Layout[,2]),3,1) } else { barSide[node] <- ifelse(Layout[node,1]>mean(Layout[,1]),4,2) } } else { barSide[node] <- sum((atan2(scale(Layout[,1])[node],scale(Layout[,2])[node])+pi)%%(2*pi) > c(0,pi/2,pi,1.5*pi)) } bars[[node]] <- pnorm(GroupThresh$est[GroupThresh$lhs == GroupVars$name[node]]) } } } # curveScale: curveScale <- ! layout %in% c('tree','tree2','tree3') # curveScale <- TRUE ### RUN QGRAPH ### qgraphRes[[which(Groups==gr)]] <- qgraph::qgraph(Edgelist, labels=nLab, bidirectional=Bidir, directed=Directed, shape=Shape, layout=Layout, lty=lty, loopRotation=loopRotation, curve=Curve, edge.labels=eLab, mar=Mar, vsize = vSize, vsize2 = vSize2, edge.color=eColor, groups=NodeGroups2, color=Vcolors, residuals=LoopAsResid, residScale = residScale, residEdge = isResid, edgelist = TRUE, curveDefault = curveDefault, knots = GroupPars$knot, # curvePivot = curvePivot, aspect = layoutSplit, CircleEdgeEnd = CircleEdgeEnd, curveScale = curveScale, bars = bars, barSide = barSide, barColor = tColor, barLength = thresholdSize, barsAtSide = ThreshAtSide, edge.label.cex = edge.label.cex, edgeConnectPoints = ECP, ...) # if (thresholds) # { # # Overwrite color to white if bg is dark (temporary solution) # if (missing(thresholdColor) & missing(edge.color)) # { # if (mean(col2rgb(qgraphRes[[which(Groups==gr)]]$plotOptions$background)/255) <= 0.5) tColor <- rep("white",length(tColor)) # } # if (nrow(GroupThresh) > 0) # { # for (i in 1:nrow(GroupThresh)) # { # node <- which(Labels==GroupThresh$lhs[i]) # # Compute side: # IntSide <- 1 # if (layout=="tree") # { # if (rotation%in%c(1,3)) # { # IntSide <- ifelse(Layout[node,2]>mean(Layout[,2]),3,1) # } else { # IntSide <- ifelse(Layout[node,1]>mean(Layout[,1]),4,2) # } # } else { # IntSide <- sum((atan2(qgraphRes[[which(Groups==gr)]]$layout[node,1],qgraphRes[[which(Groups==gr)]]$layout[node,2])+pi)%%(2*pi) > c(0,pi/2,pi,1.5*pi)) # } # IntInNode(qgraphRes[[which(Groups==gr)]]$layout[node,,drop=FALSE],vSize[node],Shape[node],pnorm(GroupThresh$est[i]),width=0.5,triangles=FALSE,col=tColor[i],IntSide,!ThreshAtSide) # } # } # } if (title) { # if (length(Groups)==1) title("Path Diagram",line=3) else title(paste0("Path Diagram for group '",gr,"'"),line=3) title(gr, col.main=title.color, adj = title.adj, outer = TRUE, cex.main = title.cex, line = title.line) } } par(ask=askOrig) if (length(qgraphRes)==1) qgraphRes <- qgraphRes[[1]] invisible(qgraphRes) } semPlot/R/semstandmsem.R0000644000176200001440000000130514267410262014724 0ustar liggesusers# Original code from sem package, by John Fox and Adam Kramer. standcoefmsem <- function (object, ...) { Res <- list() groups <- object$groups G <- length(groups) param.names <- object$param.names ram <- object$ram A <- object$A P <- object$P par <- coef(object) for (g in 1:G) { par.names <- param.names[ram[[g]][, 4]] par.gr <- par[par.names] t <- length(par.gr) par.posn <- ram[[g]][, 4] != 0 ram[[g]][par.posn, 4] <- 1:t group <- list(coeff = par.gr, t = t, ram = ram[[g]], A = A[[g]], P = P[[g]], par.posn = par.posn, param.names = par.names) class(group) <- "sem" Res[[g]] <- standardizedCoefficients(group, ...) } return(Res) }semPlot/R/amos.R0000644000176200001440000001503514267410262013170 0ustar liggesusers semPlotModel_Amos <- function(object) { ## Warnings: warning("(Residual) variances of Amos model is not yet supported") # Read characters: str <- readChar(object,nchars=file.info(object)$size) # Extract Estimates section: estLocs <- gregexpr('
',str)[[1]] nModel <- length(estLocs) Parss <- list() # Open and close div: open <- gregexpr("",str)[[1]] for (mod in 1:nModel) { startSect <- which(open==estLocs[mod]) # Find title: titleString <- substring(str,open[startSect+1],close[which(close>open[startSect+1])[1]]) modName <- regmatches(titleString,regexpr("(?<=
).*?(?=
)",titleString,perl=TRUE)) # Find close: nest <- 1 curOpen <- startSect + 1 curClose <- which(close>open[curOpen])[1] repeat{ # If next is opened: if (open[curOpen] < close[curClose]) { nest <- nest + 1 curOpen <- curOpen + 1 } else { # If next is closed: nest <- nest - 1 if (nest==0) break curClose <- curClose + 1 } } EstTabs <- substring(str,open[startSect],close[curClose] + 5) # Extract tables: Tabs <- readHTMLTable(EstTabs) # Find names of tables; Tabspl <- strsplit(EstTabs,split="")[[1]] Names <- regmatches(Tabspl,gregexpr('(?<=nodecaption=").*(?=">)',Tabspl,perl=TRUE))[-length(Tabspl)] Names <- sapply(Names,function(x)x[length(x)]) names(Tabs) <- Names # Regression weights: Reg <- Tabs[[which(grepl("regression",names(Tabs),ignore.case=TRUE))[1]]] Reg <- as.data.frame(lapply(Reg,as.character),stringsAsFactors=FALSE) if (is.null(Reg$Estimate)) Reg$Estimate <- 1 if (is.null(Reg$Label)) Reg$Label <- "" # Make Pars: # Define Pars: Pars <- data.frame( label = Reg$Label, lhs = Reg[,3], edge = "->", rhs = Reg[,1], est = as.numeric(gsub(",",".",Reg$Estimate)), std = NA, group = modName, fixed = FALSE, par = 0, stringsAsFactors=FALSE) # Pars$par <- 1:nrow(Pars) Pars$label[is.na(Pars$label)] <- "" # # Fix edges: # Pars$edge[Reg[,2]=="<---"] <- "->" # Pars$edge[Reg[,2]=="<-->"] <- "<->" # Test for fixed: if (!is.null(Reg$P)) Pars$fixed <- is.na(Reg$P) # Standardized values: if (any(grepl("standardized",names(Tabs),ignore.case=TRUE))) { Std <- Tabs[[which(grepl("standardized",names(Tabs),ignore.case=TRUE))[1]]] Std <- as.data.frame(lapply(Std,as.character),stringsAsFactors=FALSE) if (is.null(Std$Estimate)) Std$Estimate <- 1 Pars$std <- as.numeric(gsub(",",".",Std$Estimate)) } # Add covariances: if (any(grepl("covariance",names(Tabs),ignore.case=TRUE))) { Cov <- Tabs[[which(grepl("covariance",names(Tabs),ignore.case=TRUE))[1]]] Cov <- as.data.frame(lapply(Cov,as.character),stringsAsFactors=FALSE) if (is.null(Cov$Estimate)) Cov$Estimate <- 1 if (is.null(Cov$Label)) Cov$Label <- "" covPars <- data.frame( label = Cov$Label, lhs = Cov[,3], edge = "<->", rhs = Cov[,1], est = as.numeric(gsub(",",".",Cov$Estimate)), std = NA, group = modName, fixed = FALSE, par = 0, stringsAsFactors=FALSE) if (!is.null(Cov$P)) covPars$fixed <- is.na(Cov$P) # Check cors: if (any(grepl("correlation",names(Tabs),ignore.case=TRUE))) { Cor <- Tabs[[which(grepl("correlation",names(Tabs),ignore.case=TRUE))[1]]] Cor <- as.data.frame(lapply(Cor,as.character),stringsAsFactors=FALSE) if (is.null(Cor$Estimate)) Cor$Estimate <- 1 covPars$std <- Cor$Estimate } Pars <- rbind(Pars,covPars) } Parss[[mod]] <- Pars } Pars <- do.call(rbind,Parss) Pars$par <- 1:nrow(Pars) ## Extract variable info: startSect <- which(open==gregexpr('
open[curOpen])[1] repeat{ # If next is opened: if (open[curOpen] < close[curClose]) { nest <- nest + 1 curOpen <- curOpen + 1 } else { nest <- nest - 1 if (nest==0) break curClose <- curClose + 1 } } VarList <- substring(str,open[startSect],close[curClose] + 5) # Reove html tags: VarList <- gsub("<(.|\n)*?>","",VarList) # Per line: VarList <- scan(text=VarList,what="character",sep="\n") # Remove leading and trailing whitespace: VarList <- gsub("^\\s*","",VarList) VarList <- gsub("\\s*$","",VarList) AllVars <- unique(c(Pars$lhs,Pars$rhs)) AllVars <- AllVars[AllVars!=""] # Location of indicators: # manEndo - latEndo - manExo - latExo grepRep <- function(...) { res <- grep(...) if (length(res)==0) res <- -1 return(res[1]) } ind <- c( grepRep("Observed, endogenous variables",VarList), grepRep("Unobserved, endogenous variables",VarList), grepRep("Observed, exogenous variables",VarList), grepRep("Unobserved, exogenous variables",VarList)) if (ind[1] > 0) { manEndo <- VarList[(ind[1]+1):(which((1:length(VarList) == length(VarList)) | (1:length(VarList) > ind[1]+1 & 1:length(VarList) %in% ind))[1] - 1)] } else manEndo <- character(0) if (ind[2] > 0) { latEndo <- VarList[(ind[2]+1):(which((1:length(VarList) == length(VarList)) | (1:length(VarList) > ind[2]+1 & 1:length(VarList) %in% ind))[1] - 1)] } else latEndo <- character(0) if (ind[3] > 0) { manExo <- VarList[(ind[3]+1):(which((1:length(VarList) == length(VarList)) | (1:length(VarList) > ind[3]+1 & 1:length(VarList) %in% ind))[1] - 1)] } else manExo <- character(0) if (ind[4] > 0) { latExo <- VarList[(ind[4]+1):(which((1:length(VarList) == length(VarList)) | (1:length(VarList) > ind[4]+1 & 1:length(VarList) %in% ind))[1] - 1)] } else latExo <- character(0) Vars <- data.frame( name = c(manEndo,manExo,latEndo,latExo), manifest = c(rep(TRUE,length(c(manEndo,manExo))),rep(FALSE,length(c(latEndo,latExo)))), exogenous = c(rep(FALSE,length(manEndo)),rep(TRUE,length(manExo)),rep(FALSE,length(latEndo)),rep(TRUE,length(latExo))), stringsAsFactors=FALSE) # Return: semModel <- new("semPlotModel") semModel@Pars <- Pars semModel@Vars <- Vars semModel@Computed <- FALSE semModel@Original <- list(str) semModel@ObsCovs <- list() semModel@ImpCovs <- list() # semModel@Thresholds <- Thresh return(semModel) }semPlot/R/defExo.R0000644000176200001440000000352714267410262013446 0ustar liggesusersdefExo <- function(object,layout="tree") { manNames <- object@Vars$name[object@Vars$manifest] latNames <- object@Vars$name[!object@Vars$manifest] # Define exogenous variables (only if any is NA): if (any(is.na(object@Vars$exogenous))) { if (any(!is.na(object@Vars$exogenous))) { exoOrig <- object@Vars$exogenous repExo <- TRUE } else repExo <- FALSE object@Vars$exogenous <- FALSE for (i in which(!object@Vars$manifest)) { if (!any(object@Pars$edge[object@Pars$rhs==object@Vars$name[i]] %in% c("~>","->") & object@Pars$lhs[object@Pars$rhs==object@Vars$name[i]]%in%latNames)) { object@Vars$exogenous[i] <- TRUE } } for (i in which(object@Vars$manifest)) { if (all(object@Pars$lhs[object@Pars$rhs==object@Vars$name[i] & object@Pars$lhs%in%latNames]%in%object@Vars$name[object@Vars$exogenous]) & all(object@Pars$rhs[object@Pars$lhs==object@Vars$name[i] & object@Pars$rhs%in%latNames]%in%object@Vars$name[object@Vars$exogenous]) & !any(object@Pars$rhs==object@Vars$name[i] & object@Pars$edge=="~>")) { object@Vars$exogenous[i] <- TRUE } } # If all exo, treat all as endo: if (all(object@Vars$exogenous) | layout%in%c("circle","circle2","circle3")) { object@Vars$exogenous <- FALSE } # If al endo, treat formative manifest as exo (MIMIC mode), unless all manifest are formative. if (!any(object@Vars$exogenous)) { if (any(object@Vars$manifest & (object@Vars$name%in%object@Pars$rhs[object@Pars$edge %in% c("~>","--","->")]))) object@Vars$exogenous[object@Vars$manifest & !(object@Vars$name%in%object@Pars$rhs[object@Pars$edge %in% c("~>","--","->")])] <- TRUE } if (repExo) { object@Vars$exogenous[!is.na(exoOrig)] <- exoOrig[!is.na(exoOrig)] } } return(object) }semPlot/R/00classes.R0000644000176200001440000000670314267410262014030 0ustar liggesusers## SemPlotModel # Note on edge specification: # '->' is factor loading # '~>' is regression # '<->' is (co)variance # 'int' is an intercept setClass( "semPlotModel", representation( Pars = "data.frame", Vars = "data.frame", Thresholds = "data.frame", Computed = "logical", ObsCovs = "list", ImpCovs = "list", Original = "list")) setGeneric("semPlotModel_S4", function(object,...) { standardGeneric("semPlotModel_S4") }) # # setGeneric("semPaths.S4", function(object,...) { # standardGeneric("semPaths.S4") # }) # # semPaths <- function(object,...) # { # if ("MxRAMModel"%in%class(object)) return(semPaths_MxRAMModel(object,...)) # if ("MxModel"%in%class(object)) return(semPaths_MxModel(object,...)) # if(isS4(object)) # { # semPaths.S4(object, ...) # } else # { # UseMethod("semPaths", object) # } # } semPlotModel <- function (object, ...) { # Check if call contains a + operator, if so combine models: call <- paste(deparse(substitute(object)), collapse = "") if (grepl("\\+",call) & !grepl("\"",call) & !grepl("\'",call)) { args <- unlist(strsplit(call,split="\\+")) obs <- lapply(args,function(x)semPlotModel(eval(parse(text=x)))) Res <- obs[[1]] for (i in 2:length(obs)) Res <- Res + obs[[i]] return(Res) } if ("MxRAMModel"%in%class(object)) return(semPlotModel_MxRAMModel(object)) if ("MxModel"%in%class(object)) return(semPlotModel_MxModel(object)) if(isS4(object)) { semPlotModel_S4(object) } else { UseMethod("semPlotModel", object) } } semPlotModel.semPlotModel <- function(object,...) object # semPaths.default <- function(object,...) # { # if (is.character(object) && grepl("\\.out",object)) # { # return(semPaths(readModels(object),...)) # } # } semPlotModel.default <- function(object,...) { if (is(object,'data.frame')) { mod <- try(semPlotModel_lavaanModel(object,...),silent=TRUE) if (!"try-error"%in%class(mod)) return(mod) } if (is.character(object)) { if (!file.exists(object)) { mod <- try(semPlotModel_lavaanModel(object,...),silent=TRUE) if (!"try-error"%in%class(mod)) return(mod) else stop("Input string neither an existing file or Lavaan model.") } # Find file: if (grepl("\\.xml",object,ignore.case=TRUE)) { return(semPlotModel_Onyx(object)) } if (grepl("\\.AmosOutput",object,ignore.case=TRUE)) { return(semPlotModel_Amos(object)) } # Read first 100 lines: head <- readLines(object, 10) if (any(grepl("mplus",head,ignore.case=TRUE))) { return(semPlotModel.mplus.model(object,...)) } if (any(grepl("l\\s*i\\s*s\\s*r\\s*e\\s*l",head,ignore.case=TRUE))) { return(semPlotModel(readLisrel(object))) } # If all else fais, just try everything and assume you get errors # if it is wrong: mod <- try(semPlotModel_lavaanModel(object,...),silent=TRUE) if (!"try-error"%in%class(mod)) return(mod) mod <- try(semPlotModel.mplus.model(object,...),silent=TRUE) if (!"try-error"%in%class(mod)) return(mod) mod <- try(semPlotModel(readLisrel(object)),silent=TRUE) if (!"try-error"%in%class(mod)) return(mod) mod <- try(semPlotModel_Onyx(object),silent=TRUE) if (!"try-error"%in%class(mod)) return(mod) mod <- try(semPlotModel_Amos(object),silent=TRUE) if (!"try-error"%in%class(mod)) return(mod) # Well, we failed... } stop("Object not recognized as SEM model") } semPlot/R/zzz.R0000644000176200001440000000054714267410262013070 0ustar liggesusers# I copied this piece of code from Lavaan mainly: # # .onAttach <- function(libname, pkgname) { # version <- read.dcf(file=system.file("DESCRIPTION", package=pkgname), # fields="Version") # packageStartupMessage("This is ",paste(pkgname, version)) # packageStartupMessage(pkgname, " is BETA software! Please report any bugs.") # }semPlot/R/factanal.R0000644000176200001440000000150514267410262013777 0ustar liggesusers# semPaths.factanal <- function(object,...) # { # invisible(semPaths(semPlotModel(object),...)) # } # ### SINGLE GROUP MODEL ### semPlotModel.factanal <- function(object, ...) { # Check if object is of class "sem": if (!"factanal"%in%class(object)) stop("Input must be a 'factanal' object") # Extract model: mod <- semPlotModel(loadings(object)) manNames <- mod@Vars$name[mod@Vars$manifest] # Fix: mod@Pars$edge <- "->" # Add residuals: Uniqueness <- object$uniquenesses residPars <- data.frame( label = "", lhs = manNames, edge = "<->", rhs = manNames, est = Uniqueness, std = Uniqueness, group = "", fixed = FALSE, par = 0, stringsAsFactors=FALSE) mod@Pars <- rbind(mod@Pars,residPars) mod@Pars$par <- 1:nrow(mod@Pars) return(mod) } semPlot/R/mplus.R0000644000176200001440000002002114267410262013360 0ustar liggesusers# # # object <- readModels(file.choose()) # semPaths.mplus.model <- function(object,...) # { # invisible(semPaths(semPlotModel(object),...)) # } readModels <- NULL semPlotModel.mplus.model <- function (object,mplusStd=c("std", "stdy", "stdyx"),...) { mplusStd <- match.arg(mplusStd) # Check for mplusAutomation: if (!requireNamespace("MplusAutomation")) stop("'MplusAutomation' package must be installed to read Mplus output.") addInteractions <- FALSE if (is.character(object)) { modfile <- object object <- MplusAutomation::readModels(object) Lambda <- NULL Beta <- NULL Psi <- NULL Theta <- NULL mod <- readLines(modfile) # Find XWITH: xs <- grep("XWITH",mod) if (length(xs)>0) { # Split: spl <- strsplit(mod[xs],split="\\|") # Find vars that interact: vars <- lapply(spl,function(x)strsplit(x[2],split="XWITH")[[1]]) # Extract Vars newvars <- sapply(spl,'[',1) # sanitize: newvars <- gsub("\\W","",newvars) vars <- lapply(vars,gsub,pattern="\\W",replacement="") addInteractions <- TRUE } } else warning("Interactions are ommited. Use semPlotModel.mplus.model on the path to mplus output file for semPlot to attempt to find assigned interactions.") if (length(object$parameters)==0) stop("No parameters detected in mplus output.") parsUS <- object$parameters$unstandardized if (is.null(parsUS$Group)) parsUS$Group <- "" if (is.null(parsUS$BetweenWithin)) parsUS$BetweenWithin <- "" if (any(grepl("\\|",parsUS$paramHeader))) { parsUS$paramHeader <- gsub("\\|", "BY", parsUS$paramHeader) warning("'|' operator replaced by BY operator.") } if (any(grepl("New.Additional.Parameters",parsUS$paramHeader))) { parsUS <- parsUS[!grepl("New.Additional.Parameters",parsUS$paramHeader),] warning("'New.Additional.Parameters' is not yet supported by semPlot. Parameters will not be shown and unexpected results might occur.") } noPars <- FALSE # Temporary fix for EFA: if (is.null(parsUS$est)) { if (!is.null(parsUS$average)) { parsUS$est <- parsUS$average parsUS$se <- parsUS$average_se } else { parsUS$est <- 0 parsUS$se <- 0 noPars <- TRUE } } # Only find fixed if SE is present: if (!is.null(parsUS$se)){ fixed <- parsUS$se==0 } else { fixed <- FALSE } # Define Pars: Pars <- data.frame( label = "", lhs = "", edge = "--", rhs = parsUS$param, est = parsUS$est, std = NA, group = parsUS$Group, fixed = fixed, par = 0, BetweenWithin = parsUS$BetweenWithin, stringsAsFactors=FALSE) # This code will check if parameters are equal. Check on as many of these columns as possible: checkCols <- c("est","se", "posterior_sd" ,"pval","lower_2.5ci","upper_2.5ci" ) checkCols <- checkCols[checkCols %in% names(parsUS)] if (!noPars) { parNums <- dlply(cbind(sapply(parsUS[checkCols],function(x)round(as.numeric(x),10)),data.frame(num=1:nrow(parsUS))),checkCols,'[[',"num") for (i in 1:length(parNums)) Pars$par[parNums[[i]]] <- i Pars$par[Pars$fixed] <- 0 } else Pars$par <- 1:nrow(Pars) # # c <- 1 # for (i in 1:nrow(Pars)) # { # if (!isTRUE(Pars$fixed[i]) & Pars$par[i]==0) # { # par <- sapply(1:nrow(parsUS),function(j)isTRUE(all.equal(unlist(parsUS[j,c("est","se","est_se","pval")]),unlist(parsUS[i,c("est","se","est_se","pval")])))) # Pars$par[par] <- c # c <- c+1 # } # } #Standardization #mplusStd <- modelOpts$mplusStd #Call args from semPaths() # if (!is.null(object$parameters$std.standardized) & # (grepl("stand",sys.call(which =1)[3])|grepl("std",sys.call(which =1)[3])) & sys.call(3)$mplusStd=="std") # { # Pars$std <- object$parameters$std.standardized$est # warning("Mplus std parameters will be plotted. To change that, use the modelOpts argument and set mplusStd to stdy, or stdyx parameters.") # }else if (!is.null(object$parameters$stdy.standardized) & sys.call(3)$mplusStd=="stdy"){ # Pars$std <- object$parameters$stdy.standardized$est # }else if (!is.null(object$parameters$stdyx.standardized) & sys.call(3)$mplusStd=="stdyx"){ # Pars$std <- object$parameters$stdyx.standardized$est # } if (!is.null(object$parameters$std.standardized) && mplusStd == "std") { Pars$std <- object$parameters$std.standardized$est # warning("Mplus std parameters will be plotted. To change that, use the modelOpts argument and set mplusStd to stdy, or stdyx parameters.") } else if (!is.null(object$parameters$stdy.standardized) && mplusStd == "stdy") { Pars$std <- object$parameters$stdy.standardized$est } else if (!is.null(object$parameters$stdyx.standardized) && mplusStd == "stdyx") { Pars$std <- object$parameters$stdyx.standardized$est } else if (!is.null(object$parameters$standardized)) { Pars$std <- object$parameters$standardized$est } Pars$lhs[grepl(".BY$",parsUS$paramHeader)] <- gsub("\\.BY$","",parsUS$paramHeader[grepl(".BY$",parsUS$paramHeader)]) Pars$edge[grepl(".BY$",parsUS$paramHeader)] <- "->" Pars$lhs[grepl(".ON$",parsUS$paramHeader)] <- gsub("\\.ON$","",parsUS$paramHeader[grepl(".ON$",parsUS$paramHeader)]) Pars$edge[grepl(".ON$",parsUS$paramHeader)] <- "~>" Pars[grepl(".ON$",parsUS$paramHeader),c("lhs","rhs")] <- Pars[grepl(".ON$",parsUS$paramHeader),c("rhs","lhs")] Pars$lhs[grepl(".WITH$",parsUS$paramHeader)] <- gsub("\\.WITH$","",parsUS$paramHeader[grepl(".WITH$",parsUS$paramHeader)]) Pars$edge[grepl(".WITH$",parsUS$paramHeader)] <- "<->" Pars$lhs[grepl("Variances",parsUS$paramHeader)] <- Pars$rhs[grepl("Variances",parsUS$paramHeader)] Pars$edge[grepl("Variances",parsUS$paramHeader)] <- "<->" Pars$edge[grepl("Means|Intercepts",parsUS$paramHeader)] <- "int" # Extract threshold model: Thresh <- Pars[grepl("Thresholds",parsUS$paramHeader),-(3:4)] Thresh$lhs <- gsub("\\$.*","",Pars$rhs[grepl("Thresholds",parsUS$paramHeader)]) Thresh$BetweenWithin[Thresh$BetweenWithin == "Between"] <- "Within" Pars <- Pars[!grepl("Thresholds",parsUS$paramHeader),] # Detect latent/manifest: Latents <- unique(gsub("\\.BY$","",parsUS$paramHeader[grepl(".BY$",parsUS$paramHeader)])) var <- unique(unlist(Pars[c("lhs","rhs")])) var <- var[var!=""] # Variable dataframe: Vars <- data.frame( name = var, manifest = !var%in%Latents, exogenous = NA, stringsAsFactors=FALSE) ### Add interactions and remove dummy variables: if (addInteractions) { Vars <- Vars[!tolower(Vars$name)%in%tolower(newvars),] Pars$knot <- 0 k <- 1 for (i in rev(seq_along(newvars))) { varlocs <- which(tolower(Pars$lhs)==tolower(newvars[i])|tolower(Pars$rhs)==tolower(newvars[i])) for (v in seq_along(varlocs)) { for (j in 1:length(vars[[i]])) { Parsnew <- Pars[varlocs[v],] Parsnew$lhs[tolower(Parsnew$lhs)==tolower(newvars[i])] <- Vars$name[match(tolower(vars[[i]][j]),tolower(Vars$name))] Parsnew$rhs[tolower(Parsnew$rhs)==tolower(newvars[i])] <- Vars$name[match(tolower(vars[[i]][j]),tolower(Vars$name))] if (Parsnew$knot==0) { Parsnew$knot <- k } Pars <- rbind(Pars,Parsnew) } if (any(Pars$knot==k)) k <- k + 1 } Pars <- Pars[-varlocs,] } } # Abbreviate names with more than 8 characters: Pars$lhs <- substring(Pars$lhs,1,8) Pars$rhs <- substring(Pars$rhs,1,8) Vars$name <- substring(Vars$name,1,8) Vars <- Vars[!duplicated(Vars),] semModel <- new("semPlotModel") semModel@Pars <- Pars semModel@Vars <- Vars semModel@Computed <- TRUE semModel@Original <- list(object) semModel@ObsCovs <- list() semModel@Thresholds <- Thresh ImpCovs <- semMatrixAlgebra(semModel, Lambda %*% Imin(Beta, TRUE) %*% Psi %*% t(Imin(Beta, TRUE)) %*% t(Lambda) + Theta,model = "mplus") if (!is.list(ImpCovs)) ImpCovs <- list(ImpCovs) semModel@ImpCovs <- ImpCovs return(semModel) } semPlot/R/editFuns.R0000644000176200001440000000331014267410262014003 0ustar liggesusers# Extract exogenous variables: exo <- function(x) { if (!"semPlotModel"%in%class(x)) stop("'semPlotModel' object is required") x@Vars$name[!is.na(x@Vars$exogenous)][x@Vars$exogenous[!is.na(x@Vars$exogenous)]] } # Set exogenous variables: "exo<-" <- function(x,value) { if (!"semPlotModel"%in%class(x)) stop("'semPlotModel' object is required") x@Vars$name[!is.na(x@Vars$exogenous)][x@Vars$exogenous[!is.na(x@Vars$exogenous)]] <- FALSE x@Vars$exogenous[x@Vars$name%in%value] <- TRUE return(x) } # Extract endogenous variables: endo <- function(x) { if (!"semPlotModel"%in%class(x)) stop("'semPlotModel' object is required") x@Vars$name[!is.na(x@Vars$exogenous)][!x@Vars$exogenous[!is.na(x@Vars$exogenous)]] } # Set endogenous variables: "endo<-" <- function(x,value) { if (!"semPlotModel"%in%class(x)) stop("'semPlotModel' object is required") x@Vars$name[!is.na(x@Vars$exogenous)][!x@Vars$exogenous[!is.na(x@Vars$exogenous)]] <- TRUE x@Vars$exogenous[x@Vars$name%in%value] <- FALSE return(x) } # Extract manifest variables: man <- function(x) { if (!"semPlotModel"%in%class(x)) stop("'semPlotModel' object is required") x@Vars$name[x@Vars$manifest] } # Set manifest variables: "man<-" <- function(x,value) { if (!"semPlotModel"%in%class(x)) stop("'semPlotModel' object is required") x@Vars$manifest[x@Vars$name%in%value] <- TRUE return(x) } # Extract latent variables: lat <- function(x) { if (!"semPlotModel"%in%class(x)) stop("'semPlotModel' object is required") x@Vars$name[!x@Vars$manifest] } # Set latent variables: "lat<-" <- function(x,value) { if (!"semPlotModel"%in%class(x)) stop("'semPlotModel' object is required") x@Vars$manifest[x@Vars$name%in%value] <- FALSE return(x) }semPlot/R/semCors.R0000644000176200001440000000456114267410262013646 0ustar liggesuserssemCors <- function(object,include,vertical=TRUE,titles=FALSE,layout,maximum,...){ if (!"semPlotModel"%in%class(object)) object <- semPlotModel(object) if (!object@Computed) stop("SEM model has not been evaluated; there are no implied covariances") if (missing(layout)) layout <- NULL Ng <- max(sapply(list(object@ObsCovs,object@ImpCovs),length)) if (missing(include)) { include <- c("observed","expected")[c(length(object@ObsCovs)==Ng,length(object@ImpCovs)==Ng)] } Groups <- unique(object@Pars$group) l <- matrix(1:(Ng*length(include)),length(include),) if (vertical) layout(t(l)) else layout(l) Res <- list() for (g in 1:Ng) { Res[[g]] <- list() if (any(grepl("obs",include,ignore.case=TRUE))) { Res[[g]]$Observed <- qgraph(round(cov2cor(object@ObsCovs[[g]]),5),maximum=ifelse(missing(maximum),1,maximum),layout=layout,...) layout <- Res[[g]]$Observed$layout if (titles) { if (Ng > 1) { text(mean(par('usr')[1:2]),par("usr")[4],paste("Group",Groups[g],"(observed)"), adj = c(0.5,1)) } else { text(mean(par('usr')[1:2]),par("usr")[4],"Observed", adj = c(0.5,1)) } } } if (any(grepl("exp",include,ignore.case=TRUE)) | any(grepl("imp",include,ignore.case=TRUE))) { Res[[g]]$Implied <- qgraph(round(cov2cor(object@ImpCovs[[g]]),5),maximum=ifelse(missing(maximum),1,maximum),layout=layout,...) layout <- Res[[g]]$Implied$layout if (titles) { if (Ng > 1) { text(mean(par('usr')[1:2]),par("usr")[4],paste("Group",Groups[g],"(implied)"), adj = c(0.5,1)) } else { text(mean(par('usr')[1:2]),par("usr")[4],"Implied", adj = c(0.5,1)) } } } if (any(grepl("dif",include,ignore.case=TRUE)) | any(grepl("res",include,ignore.case=TRUE))) { Res[[g]]$Difference <- qgraph(round(cov2cor(object@ObsCovs[[g]]) - cov2cor(object@ImpCovs[[g]]),5),maximum=ifelse(missing(maximum),.1,maximum),layout=layout,diag = TRUE, ...) if (titles) { if (Ng > 1) { text(mean(par('usr')[1:2]),par("usr")[4],paste("Group",Groups[g],"(observed - implied)"), adj = c(0.5,1)) } else { text(mean(par('usr')[1:2]),par("usr")[4],"Observed - Implied", adj = c(0.5,1)) } } } } invisible(Res) }semPlot/R/lisrelModel.R0000644000176200001440000003422114267410262014502 0ustar liggesuserssemPlotModel.lisrel <- function(object,...) { Res <- do.call(lisrelModel, c(object$matrices,list(...))) Res@Original <- list(object) return(Res) } InvEmp <- function(x) { if (any(dim(x)==0)) { return(array(0,dim=dim(x))) } else { res <- tryCatch(solve(x), error = function(e) FALSE, silent = TRUE) if (is.matrix(res)) return(res) else { res <- tryCatch(pseudoinverse(x), error = function(e) FALSE, silent = TRUE) if (is.matrix(res)) { warning("Psuedoinverse used for singular matrix. Standardized solution might not be proper.") return(res) } else { warning("Uninvertable matrix found and psuedoinverse could not be computed. Standardized solutions probably not proper.") return(array(0, dim=dim(x))) } } } } fixMatrix <- function(m) { # If not a list (matrix itself added) put matrix in list (group 1) in list: if (!is.list(m)) { if (is.matrix(m)|is.vector(m)) { m <- list(list(est=m)) } else stop("Wrong input for matrix") } else if ("est"%in%names(m)) { # Else if list, check if it is not a list of lists m <- list(m) } # Else check if empty list: if (length(m)>0) { # Assume multigroup. Check if all elements are list: if (!all(sapply(m,is.list))) stop("Not all elements are a list") # Clean each group: for (g in seq_along(m)) { # Copy parSpec to par (lisrelToR compatibility) if (is.empty(m[[g]][['par']]) & !is.empty(m[[g]][['parSpec']])) { m[[g]][['par']] <- m[[g]][['parSpec']] } if (is.empty(m[[g]][['fixed']])) { if (!is.empty(m[[g]][['par']])) { m[[g]][['fixed']] <- m[[g]][['par']]==0 } else if (!is.empty(m[[g]][['parSpec']])) { m[[g]][['fixed']] <- m[[g]][['parSpec']]==0 } } if (!is.empty(m[[g]][['stdComp']])) { m[[g]][['std']] <- m[[g]][['stdComp']] } if (is.empty(m[[g]][['est']])) m[[g]] <- list() } } return(m) } is.empty <- function(x) is.null(x) || any(dim(x)==0) ### SINGLE GROUP MODEL ### lisrelModel <- function(LY,PS,BE,TE,TY,AL,manNamesEndo,latNamesEndo,LX,PH,GA,TD,TX,KA,manNamesExo,latNamesExo,ObsCovs,ImpCovs,setExo,modelLabels = FALSE, reduce = TRUE) { # Input matrices either in matrix form or list containing 'est', 'std', ; fixed', and 'par' or 'parSpec' matrices. If 'stdComp' is in the list it overwrites 'std' (compatibility with 'lisrelToR' package): # Or a list of such lists for each group. # Check input, replace matrices with list: mats <- c("LY","PS","BE","TE","TY","AL","LX","PH","GA","TD","TX","KA") for (m in mats) { if (!do.call(missing,list(m))) { assign(m,fixMatrix(get(m))) } else { assign(m,list()) } } ### NAMES ### # If names missing, set default:: if (missing(manNamesEndo)) { if (length(LY)>0 && !is.empty(LY[[1]]$est)) { if (!is.null(rownames(LY[[1]]$est)) && !modelLabels) { manNamesEndo <- rownames(LY[[1]]$est) } else manNamesEndo <- paste0("y[",seq_len(nrow(LY[[1]]$est)),"]") } else if (length(TE)>0 && !is.empty(TE[[1]]$est)) { if (!is.null(rownames(TE[[1]]$est)) && !modelLabels) { manNamesEndo <- rownames(TE[[1]]$est) } else manNamesEndo <- paste0("y[",seq_len(nrow(TE[[1]]$est)),"]") } else if (length(TY)>0 && !is.empty(TY[[1]]$est)) { manNamesEndo <- paste0("y[",seq_along(TY[[1]]$est),"]") } else manNamesEndo <- character(0) } if (missing(latNamesEndo)) { if (length(LY)>0 && !is.empty(LY[[1]]$est)) { if (!is.null(colnames(LY[[1]]$est)) && !modelLabels) { latNamesEndo <- colnames(LY[[1]]$est) } else latNamesEndo <- paste0("eta[",1:ncol(LY[[1]]$est),"]") } else if (length(PS)>0 && !is.empty(PS[[1]]$est)) { if (!is.null(colnames(PS[[1]]$est)) && !modelLabels) { latNamesEndo <- colnames(PS[[1]]$est) } else latNamesEndo <- paste0("eta[",1:ncol(PS[[1]]$est),"]") } else if (length(BE)>0 && !is.empty(BE[[1]]$est)) { if (!is.null(colnames(BE[[1]]$est)) && !modelLabels) { latNamesEndo <- colnames(BE[[1]]$est) } else latNamesEndo <- paste0("eta[",1:ncol(BE[[1]]$est),"]") } else if (length(AL)>0 && !is.empty(AL[[1]]$est)) { latNamesEndo <- paste0("eta[",seq_along(AL[[1]]$est),"]") } else latNamesEndo <- character(0) } # If names missing, set default:: if (missing(manNamesExo)) { if (length(LX)>0 && !is.empty(LX[[1]]$est)) { if (!is.null(rownames(LX[[1]]$est)) && !modelLabels) { manNamesExo <- rownames(LX[[1]]$est) } else manNamesExo <- paste0("x[",seq_len(nrow(LX[[1]]$est)),"]") } else if (length(TD)>0 && !is.empty(TD[[1]]$est)) { if (!is.null(rownames(TD[[1]]$est)) && !modelLabels) { manNamesExo <- rownames(TD[[1]]$est) } else manNamesExo <- paste0("x[",seq_len(nrow(TD[[1]]$est)),"]") } else if (length(TX)>0 && !is.empty(TX[[1]]$est)) { manNamesExo <- paste0("x[",seq_along(TX[[1]]$est),"]") } else manNamesExo <- character(0) } if (missing(latNamesExo)) { if (length(LX)>0 && !is.empty(LX[[1]]$est)) { if (!is.null(colnames(LX[[1]]$est)) && !modelLabels) { latNamesExo <- colnames(LX[[1]]$est) } else latNamesExo <- paste0("xi[",1:ncol(LX[[1]]$est),"]") } else if (length(PH)>0 && !is.empty(PH[[1]]$est)) { if (!is.null(colnames(PH[[1]]$est)) && !modelLabels) { latNamesExo <- colnames(PH[[1]]$est) } else latNamesExo <- paste0("xi[",1:ncol(PH[[1]]$est),"]") } else if (length(GA)>0 && !is.empty(GA[[1]]$est)) { if (!is.null(colnames(GA[[1]]$est)) && !modelLabels) { latNamesExo <- colnames(GA[[1]]$est) } else latNamesExo <- paste0("xi[",1:ncol(GA[[1]]$est),"]") } else if (length(KA)>0 && !is.empty(KA[[1]]$est)) { latNamesExo <- paste0("xi[",seq_along(KA[[1]]$est),"]") } else latNamesExo <- character(0) } # Check for duplicate names: if (!reduce) { redFun <- function(x,y,app) { x[x%in%y] <- paste0(x[x%in%y],app) return(x) } latNamesEndo <- redFun(latNamesEndo,c(latNamesExo,manNamesExo,manNamesEndo),"_Len") latNamesExo <- redFun(latNamesExo,c(latNamesEndo,manNamesEndo,manNamesExo),"_Lex") manNamesEndo <- redFun(manNamesEndo,c(manNamesExo,latNamesEndo,latNamesExo),"_Men") manNamesExo <- redFun(manNamesExo,c(manNamesEndo,latNamesEndo,latNamesExo),"_Mex") } Len <- sapply(mats,function(x)length(get(x))) Len <- Len[Len>0] if (length(unique(Len))>1) stop("Number of groups are not equal across all given LISREL matrices.") Ng <- max(Len) Parss <- list() dumPars <- data.frame( label = character(0), lhs = character(0), edge = character(0), rhs = character(0), est = numeric(0), std = numeric(0), group = character(0), fixed = logical(0), par = numeric(0), stringsAsFactors=FALSE) if (missing(ImpCovs)) { modCovs <- list() } for (g in 1:Ng) { # Compute model implied covariance matrix and standardized matrices: # M is matrix list: M <- list() # Exogenous: if (length(LX)>0 && !is.empty(LX[[g]]$est)) { M$LX <- LX[[g]]$est } else { M$LX <- matrix(,0,0) } if (length(PH)>0 && !is.empty(PH[[g]]$est)) { M$PH <- PH[[g]]$est } else { M$PH <- diag(1,ncol(M$LX),ncol(M$LX)) } if (length(TD)>0 && !is.empty(TD[[g]]$est)) { M$TD <- TD[[g]]$est } else { M$TD <- matrix(0,nrow(M$LX),nrow(M$LX)) } # Endogenous: if (length(LY)>0 && !is.empty(LY[[g]]$est)) { M$LY <- LY[[g]]$est } else { M$LY <- matrix(,0,0) } if (length(PS)>0 && !is.empty(PS[[g]]$est)) { M$PS <- PS[[g]]$est } else { M$PS <- diag(1,ncol(M$LY),ncol(M$LY)) } if (length(TE)>0 && !is.empty(TE[[g]]$est)) { M$TE <- TE[[g]]$est } else { M$TE <- matrix(0,nrow(M$LY),nrow(M$LY)) } if (length(BE)>0 && !is.empty(BE[[g]]$est)) { M$BE <- BE[[g]]$est } else { M$BE <- matrix(0,ncol(M$LY),ncol(M$LY)) } if (length(GA)>0 && !is.empty(GA[[g]]$est)) { M$GA <- GA[[g]]$est } else { M$GA <- matrix(0,ncol(M$LY),ncol(M$LX)) } ImBinv <- InvEmp(diag(1,nrow(M$BE),ncol(M$BE)) - M$BE) # Implied covariances: XX <- with(M, LX %*% PH %*% t(LX) + TD) YY <- with(M, LY %*% ( ImBinv %*% (GA %*% PH %*% t(GA) + PS) %*% t(ImBinv)) %*% t(LY) + TE) XY <- with(M, LX %*% PH %*% t(GA) %*% t(ImBinv) %*% t(LY)) if (missing(ImpCovs)) { modCovs[[g]] <- rbind(cbind(YY,t(XY)), cbind(XY,XX)) rownames(modCovs[[g]]) <- colnames(modCovs[[g]]) <- c(manNamesEndo,manNamesExo) } ## Standardize matrices # Diagonal matrices: EE <- with(M, ( ImBinv %*% (GA %*% PH %*% t(GA) + PS) %*% t(ImBinv)) ) M$De <- diag(sqrt(diag(EE)),nrow(EE),ncol(EE)) KK <- with(M, ( PH ) ) M$Dk <- diag(sqrt(diag(KK)),nrow(KK),ncol(KK)) M$Dx <- diag(sqrt(diag(XX)),nrow(XX),ncol(XX)) M$Dy <- diag(sqrt(diag(YY)),nrow(YY),ncol(YY)) # Inverses M$Dki <- InvEmp(M$Dk) M$Dei <- InvEmp(M$De) M$Dxi <- InvEmp(M$Dx) M$Dyi <- InvEmp(M$Dy) ## Standardize structural part: Mstd <- M # Exo: Mstd$LX <- M$LX %*% M$Dk Mstd$PH <- M$Dki %*% M$PH %*% M$Dki # Endo: Mstd$LY <- M$LY %*% M$De Mstd$PS <- M$Dei %*% M$PS %*% M$Dei Mstd$BE <- M$Dei %*% M$BE %*% M$De Mstd$GA <- M$Dei %*% M$GA %*% M$Dk ## Standardize measurment part: Mstd$LY <- M$Dyi %*% Mstd$LY Mstd$LX <- M$Dxi %*% Mstd$LX Mstd$TE <- M$Dyi %*% Mstd$TE %*% M$Dyi Mstd$TD <- M$Dxi %*% Mstd$TD %*% M$Dxi # Store matrices: if (length(LY) > 0 && !is.empty(LY[[g]]$est) && is.empty(LY[[g]]$std)) LY[[g]]$std <- Mstd$LY if (length(LX) > 0 && !is.empty(LX[[g]]$est) && is.empty(LX[[g]]$std)) LX[[g]]$std <- Mstd$LX if (length(TE) > 0 && !is.empty(TE[[g]]$est) && is.empty(TE[[g]]$std)) TE[[g]]$std <- Mstd$TE if (length(TD) > 0 && !is.empty(TD[[g]]$est) && is.empty(TD[[g]]$std)) TD[[g]]$std <- Mstd$TD if (length(PH) > 0 && !is.empty(PH[[g]]$est) && is.empty(PH[[g]]$std)) PH[[g]]$std <- Mstd$PH if (length(PS) > 0 && !is.empty(PS[[g]]$est) && is.empty(PS[[g]]$std)) PS[[g]]$std <- Mstd$PS if (length(GA) > 0 && !is.empty(GA[[g]]$est) && is.empty(GA[[g]]$std)) GA[[g]]$std <- Mstd$GA if (length(BE) > 0 && !is.empty(BE[[g]]$est) && is.empty(BE[[g]]$std)) BE[[g]]$std <- Mstd$BE # Extract matrices: if (length(LY)>0) LYPars <- modMat2Pars(LY[[g]],"->","lambda",symmetric=FALSE,vec=FALSE,latNamesEndo,manNamesEndo,group=paste("Group",g),exprsup="^{(y)}") else LYPars <- dumPars if (length(TE)>0) TEPars <- modMat2Pars(TE[[g]],"<->","theta",symmetric=TRUE,vec=FALSE,manNamesEndo,manNamesEndo,group=paste("Group",g),exprsup="^{(epsilon)}") else TEPars <- dumPars if (length(PS)>0) PSPars <- modMat2Pars(PS[[g]],"<->","psi",symmetric=TRUE,vec=FALSE,latNamesEndo,latNamesEndo,group=paste("Group",g),exprsup="") else PSPars <- dumPars if (length(BE)>0) BEPars <- modMat2Pars(BE[[g]],"->","beta",symmetric=FALSE,vec=FALSE,latNamesEndo,latNamesEndo,group=paste("Group",g),exprsup="") else BEPars <- dumPars if (length(LX)>0) LXPars <- modMat2Pars(LX[[g]],"->","lambda",symmetric=FALSE,vec=FALSE,latNamesExo,manNamesExo,group=paste("Group",g),exprsup="^{(x)}") else LXPars <- dumPars if (length(TD)>0) TDPars <- modMat2Pars(TD[[g]],"<->","theta",symmetric=TRUE,vec=FALSE,manNamesExo,manNamesExo,group=paste("Group",g),exprsup="^{(delta)}") else TDPars <- dumPars if (length(PH)>0) PHPars <- modMat2Pars(PH[[g]],"<->","phi",symmetric=TRUE,vec=FALSE,latNamesExo,latNamesExo,group=paste("Group",g),exprsup="") else PHPars <- dumPars if (length(GA)>0) GAPars <- modMat2Pars(GA[[g]],"->","gamma",symmetric=FALSE,vec=FALSE,latNamesExo,latNamesEndo,group=paste("Group",g),exprsup="") else GAPars <- dumPars if (length(TY)>0) TYPars <- modMat2Pars(TY[[g]],"int","tau",symmetric=FALSE,vec=TRUE,"",manNamesEndo,group=paste("Group",g),exprsup="^{(y)}") else TYPars <- dumPars if (length(TX)>0) TXPars <- modMat2Pars(TX[[g]],"int","tau",symmetric=FALSE,vec=TRUE,"",manNamesExo,group=paste("Group",g),exprsup="^{(x)}") else TXPars <- dumPars if (length(AL)>0) ALPars <- modMat2Pars(AL[[g]],"int","alpha",symmetric=FALSE,vec=TRUE,"",latNamesEndo,group=paste("Group",g),exprsup="") else ALPars <- dumPars if (length(KA)>0) KAPars <- modMat2Pars(KA[[g]],"int","kappa",symmetric=FALSE,vec=TRUE,"",latNamesExo,group=paste("Group",g),exprsup="") else KAPars <- dumPars # Combine ParsS: Parss[[g]] <- rbind(LYPars,TEPars,PSPars,BEPars,LXPars,TDPars,PHPars,GAPars,TYPars,TXPars,ALPars,KAPars) # Remove zeroes: Parss[[g]] <- Parss[[g]][Parss[[g]]$est!=0,] } Pars <- do.call(rbind,Parss) # Variable dataframe: Vars <- data.frame( name = c(manNamesEndo,manNamesExo,latNamesEndo,latNamesExo), manifest = c(manNamesEndo,manNamesExo,latNamesEndo,latNamesExo)%in%c(manNamesEndo,manNamesExo), exogenous = rep(NA,length(c(manNamesEndo,manNamesExo,latNamesEndo,latNamesExo))), stringsAsFactors=FALSE) # Remove duplicates plus factor loadings betwen mans and lats of same name: Vars <- Vars[!duplicated(Vars$name),] Pars <- Pars[!(Pars$lhs==Pars$rhs&Pars$edge!="<->"),] if (length(unique(Pars$group)) == 1) Pars$group <- '' # Set exogenous: if (missing(setExo)) { setExo <- !(length(TD)>0 & length(LX)>0 & length(PH)>0 & length(GA)>0) } if (setExo) { Vars$exogenous <- c(manNamesEndo,manNamesExo,latNamesEndo,latNamesExo)%in%c(manNamesExo,latNamesExo) } semModel <- new("semPlotModel") semModel@Pars <- Pars semModel@Vars <- Vars semModel@Original <- list() if (!missing(ObsCovs)) { semModel@ObsCovs <- list(ObsCovs) } else { semModel@ObsCovs <- list() } if (!missing(ImpCovs)) { semModel@ImpCovs <- list(ImpCovs) } else { semModel@ImpCovs <- modCovs } semModel@Computed <- length(semModel@ImpCovs) > 0 return(semModel) } semPlot/R/isColor.R0000644000176200001440000000024614267410262013641 0ustar liggesusersisColor <- function(x) { sapply(x, function(X) { if (!is.logical(X)) tryCatch(is.matrix(col2rgb(X)), error = function(e) FALSE) else FALSE }) } semPlot/R/semSyntax.R0000644000176200001440000000667314267410262014234 0ustar liggesuserssemSyntax <- function(object, syntax = "lavaan", allFixed = FALSE, file) { if (!"semPlotModel" %in% class(object)) { # Try to run semPlotModel on object, otherwise stop. object <- semPlotModel(object) } if (!syntax %in% c("lavaan","sem")) stop("Only 'lavaan' and 'sem' syntax is currently supported ") if (nrow(object@Thresholds) > 0) warning("Thresholds are not yet supported by semSyntax") # If all fixed, simply set all fixed = TRUE: if (allFixed) { object@Pars$fixed <- TRUE } ### LAVAAN ### if (syntax == "lavaan") { Pars <- object@Pars # Reverse lhs and rhs: Pars[Pars$edge %in% c('~>','int'),c('lhs','rhs')] <- Pars[Pars$edge %in% c('~>','int'),c('rhs','lhs')] Pars[Pars$edge=='->'&!(Pars$lhs%in%object@Vars$name[!object@Vars$manifest] & Pars$rhs%in%object@Vars$name[object@Vars$manifest]),c('lhs','rhs')] <- Pars[Pars$edge=='->'&!(Pars$lhs%in%object@Vars$name[!object@Vars$manifest] & Pars$rhs%in%object@Vars$name[object@Vars$manifest]),c('rhs','lhs')] # Change operators: Pars$edge[Pars$edge=='->'&!(Pars$lhs%in%object@Vars$name[!object@Vars$manifest] & Pars$rhs%in%object@Vars$name[object@Vars$manifest])] <- "~" Pars$edge[Pars$edge=='->'&(Pars$lhs%in%object@Vars$name[!object@Vars$manifest] & Pars$rhs%in%object@Vars$name[object@Vars$manifest])] <- "=~" Pars$edge[Pars$edge == "~>"] <- "~" Pars$edge[Pars$edge == "<->"] <- "~~" Pars$rhs[Pars$edge == "int"] <- "1" Pars$edge[Pars$edge == "int"] <- "~" # Fixing parameters: Pars$rhs <- ifelse( Pars$fixed, paste0(Pars$est,"*",Pars$rhs), Pars$rhs) Pars$rhs <- ifelse( !Pars$fixed & Pars$par > 0 & (duplicated(Pars$par)|duplicated(Pars$par,fromLast=TRUE)), paste0("par",Pars$par,"*",Pars$rhs), Pars$rhs) # Combine and return: Mod <- paste(Pars$lhs,Pars$edge,Pars$rhs,collapse = "\n") # Print to console or file: if (missing(file)) { cat("\nModel <- '\n",Mod,"\n'\n",sep="") } else { write(paste0("\nModel <- '\n",Mod,"\n'\n"),file) } return(Mod) } ### SEM ### if (syntax == "sem") { Pars <- object@Pars # Remove intercepts: if (any(Pars$edge == "int")) { warning("Intercepts removed from model for 'sem' syntax") Pars <- Pars[Pars$edge!="int",] } Pars$label[Pars$fixed] <- NA ## Fix parameter labels. if (max(Pars$par) > 0) { for (i in seq_len(max(Pars$par))) { # Check if unique to other par numbers: if (any(Pars$label[Pars$par!=i] %in% Pars$label[Pars$par==i] | any(Pars$label[Pars$par == i] == ''))) { Pars$label[Pars$par==i] <- paste0("par",i) } # Check if labels are unique, else combine: if (length(unique(Pars$label[Pars$par == i])) > 1) { Pars$label[Pars$par==i] <- paste(Pars$label[Pars$par==i],collapse="_") } } } # Fix estimate: Pars$est[!Pars$fixed] <- NA # Fix edges: Pars$edge[Pars$edge == '~>'] <- '->' # Create model: Mod <- paste(paste(Pars$lhs, Pars$edge, Pars$rhs), Pars$label, Pars$est, sep = ",", collapse = "\n") # Print to console or file: if (missing(file)) { cat("\nModel <- specifyModel()\n",Mod,"\n\n",sep="") } else { write(paste0("\nModel <- specifyModel()\n",Mod,"\n\n",sep=""),file) } Mod <- specifyModel( textConnection( Mod )) return(Mod) } }semPlot/R/greplVarType.R0000644000176200001440000000256114267410262014655 0ustar liggesusers# grepl on varnames with special keywords: # - MAN # - LAT # - ENDO # - EXO # - INT matchVar <- function(x, Vars, manIntsExo, manIntsEndo, latIntsExo, latIntsEndo) { n <- nrow(Vars) + nrow(manIntsEndo) + nrow(manIntsExo) + nrow(latIntsEndo) + nrow(latIntsExo) Man <- c(Vars$manifest, rep(FALSE,n-nrow(Vars))) Man[c(manIntsEndo[,1],manIntsExo[,1])] <- TRUE Exo <- c(Vars$exogenous, rep(FALSE,n-nrow(Vars))) Exo[c(manIntsExo[,1],latIntsExo[,1])] <- TRUE isInt <- c(rep(FALSE,nrow(Vars)), rep(TRUE, n-nrow(Vars))) # match: matchRes <- match(x,Vars$name) matchRes <- matchRes[!is.na(matchRes)] # keywords: select <- rep(grepl("(EXO)|(ENDO)|(MAN)|(LAT)|(INT)|(VAR)",x),n) if (any(select)) { if (grepl("(ENDO)|(EXO)",x)) { # First node first / endo: select <- select & ((grepl("ENDO",x) & !Exo) | (grepl("EXO",x) & Exo ) ) } if (grepl("(LAT)|(MAN)",x)) { # Any node man / latent select <- select & ((grepl("LAT",x) & !Man) | (grepl("MAN",x) & Man ) ) } if (grepl("(INT)|(VAR)",x)) { # Any node man / latent select <- select & ((grepl("VAR",x) & !isInt) | (grepl("INT",x) & isInt ) ) } } return(c(matchRes,which(select))) }semPlot/R/loadings.R0000644000176200001440000000221114267410262014021 0ustar liggesusers# semPaths.loadings <- function(object,...) # { # invisible(semPaths(semPlotModel(object),...)) # } # ### SINGLE GROUP MODEL ### semPlotModel.loadings <- function(object, ...) { # Check if object is of class "sem": if (!"loadings"%in%class(object)) stop("Input must be a 'factanal' object") manNames <- rownames(object) latNames <- colnames(object) # Define Pars: Pars <- data.frame( label = "", lhs = rep(latNames,each=length(manNames)), edge = "--", rhs = rep(manNames,times=length(latNames)), est = c(object), std = c(object), group = "", fixed = FALSE, par = 1:length(object), stringsAsFactors=FALSE) # Variable dataframe: Vars <- data.frame( name = c(manNames[order(apply(abs(object),1,which.max))],latNames), manifest = c(rep(TRUE,nrow(object)),rep(FALSE,ncol(object))), exogenous = NA, stringsAsFactors=FALSE) semModel <- new("semPlotModel") semModel@Pars <- Pars semModel@Vars <- Vars semModel@Computed <- FALSE semModel@Original <- list(object) semModel@ObsCovs <- list() semModel@ImpCovs <- list() return(semModel) } semPlot/R/cvregsemplot.R0000644000176200001440000000602214267410262014737 0ustar liggesusers semPlotModel.cvregsem <- function(object,model,...){ if (missing(model)){ stop("Please supply lavaan model with 'model' argument!") } ## Save parts of the output in objects object1 <- object # parameters object2 <- model@ParTable # lavaan parameters varnames <- unique(c(object2$lhs, object2$rhs)) # all names mannames <- model@Model@dimNames[[1]][1] # manifest variables names(varnames) <- 'name' names(mannames) <- 'manifest' '%!in%' <- function(x,y)!('%in%'(x,y)) ## Add the fixed relations to the parameter estimates of regsem namelist <- strsplit(names(object1$final_pars)," ") # split names and operators inout <- data.frame(1,2) for(i in 1:length(namelist)){ inout[i,1] <- namelist[[i]][1] inout[i,2] <- namelist[[i]][3] } # create data frame of regsem variables int <- data.frame(1,2) for(i in 1:length(object2$lhs)){ int[i,1] <- ifelse(object2$op[i]=="~"|object2$op[i]=="~1",object2$rhs[i],object2$lhs[i]) int[i,2] <- ifelse(object2$op[i]=="~"|object2$op[i]=="~1",object2$lhs[i],object2$rhs[i]) } # create data frame of lavaan variables ## paste together pinout <- with(inout, paste0(X1, X2)) pint <- with(int, paste0(X1, X2)) counter <- 0 for(i in 1:length(object2$free)){ # if free before, if(object2$free[i] == 0){ object1$regest[i] <- 1 counter = counter + 1 } else{ object1$regest[i] <- object1$final_pars[i - counter] } } # match regsem estimates with lavaan variables, set fixed to 1 ## Create a S4 list semModel <- new("semPlotModel") ## Create a Pars data frame semModel@Pars <- data.frame( label = rep("", length(object2$id)), lhs = ifelse(object2$op=="~"|object2$op=="~1",object2$rhs,object2$lhs), # first went from left to right without checking relationship edge = "--", rhs = ifelse(object2$op=="~"|object2$op=="~1",object2$lhs,object2$rhs), est = object1$regest, # check if we should take estimates from other model, if estimates are same as in regsem std = NA, group = object2$group, fixed = object2$free == 0, par = object2$free, stringsAsFactors=FALSE) row.names(semModel@Pars) <- 1:length(object2$id) ## translate operators semModel@Pars$edge[object2$op=="~~"] <- "<->" semModel@Pars$edge[object2$op=="~*~"] <- "<->" semModel@Pars$edge[object2$op=="~"] <- "~>" semModel@Pars$edge[object2$op=="=~"] <- "->" semModel@Pars$edge[object2$op=="~1"] <- "int" semModel@Pars$edge[grepl("\\|",object2$op)] <- "|" semModel@Pars <- semModel@Pars[!object2$op%in%c(':=','<','>','==','|','<', '>'),] ## Create a vars data frame semModel@Vars <- data.frame( name = varnames, manifest = varnames[1:length(varnames)] %in% mannames$manifest[1:length(mannames$manifest)], exogenous = NA, stringsAsFactors = FALSE ) ## Miscellaneous data frames semModel@Thresholds <- data.frame() semModel@ObsCovs <- list() semModel@ImpCovs <- list() semModel@Computed <- FALSE semModel@Original <- list(object) return(semModel) } semPlot/R/mappingfuns.R0000644000176200001440000000144714267410262014562 0ustar liggesusers# Map user space to inches space: usr2inX <- function(x) { usr <- c(-1,1,-1,1) pin <- par("din") (x-usr[1])/(usr[2]-usr[1]) * pin[1] } usr2inY <- function(x) { usr <- c(-1,1,-1,1) pin <- par("din") (x-usr[3])/(usr[4]-usr[3]) * pin[2] } # Same but about origin (for atan2): usr2inX2 <- function(x) { usr <- c(-1,1,-1,1) pin <- par("din") x/(usr[2]-usr[1]) * pin[1] } usr2inY2 <- function(x) { usr <- c(-1,1,-1,1) pin <- par("din") x/(usr[4]-usr[3]) * pin[2] } atan2usr2in <- function(x,y) atan2(usr2inX2(x),usr2inY2(y))%%(2*pi) # Map inches space to user space: in2usrX <- function(x) { usr <- c(-1,1,-1,1) pin <- par("din") usr[1] + x/pin[1] * (usr[2] - usr[1]) } in2usrY <- function(x) { usr <- c(-1,1,-1,1) pin <- par("din") usr[3] + x/pin[2] * (usr[4] - usr[3]) }semPlot/R/principal.R0000644000176200001440000000102214267410262014201 0ustar liggesusers# semPaths.principal <- function(object,...) # { # invisible(semPaths(semPlotModel(object),...)) # } # ### SINGLE GROUP MODEL ### semPlotModel.principal <- function(object, ...) { # Check if object is of class "sem": if (!"principal"%in%class(object)) stop("Input must be a 'principal' object") # Extract model: mod <- semPlotModel(loadings(object)) manNames <- mod@Vars$name[mod@Vars$manifest] # Fix: mod@Pars[c("lhs","rhs")] <- mod@Pars[c("rhs","lhs")] mod@Pars$edge <- "->" return(mod) } semPlot/R/sem.R0000644000176200001440000000762414267410262013022 0ustar liggesusers# semPaths.sem <- function(object,...) # { # invisible(semPaths(semPlotModel(object),...)) # } # # semPaths.msem <- function(object,...) # { # invisible(semPaths(semPlotModel(object),...)) # } # # semPaths.msemObjectiveML <- function(object,...) # { # invisible(semPaths(semPlotModel(object),...)) # } # ### SINGLE GROUP MODEL ### semPlotModel.sem <- function(object, ...) { # Check if object is of class "sem": if (!any(class(object)%in%c("sem","semmod"))) stop("Input must be a 'sem' object") # Define Pars: Pars <- data.frame( label = rownames(object$ram), lhs = object$ram[,3], edge = "--", rhs = object$ram[,2], est = object$ram[,5], std = standardizedCoefficients(object)[,2], group = 1, fixed = object$ram[,4]==0, par = object$ram[,4], stringsAsFactors=FALSE) # Extract parameter estimates: Pars$est[object$ram[,4]!=0] <- object$coef[object$ram[,4]] # Fix labels: for (i in unique(object$ram[,4][object$ram[,4]!=0])) { if (any(Pars$label[object$ram[,4]==i]=="") & any(Pars$label[object$ram[,4]==i]!="")) { Pars$label[object$ram[,4]==i & Pars$label==""] <- Pars$label[object$ram[,4]==i & Pars$label!=""] } } # Name variables: Pars$lhs <- object$var.names[Pars$lhs] Pars$rhs <- object$var.names[Pars$rhs] # Variable dataframe: Vars <- data.frame( name = object$var.names, manifest = object$var.names %in% colnames(object$S), exogenous = NA, stringsAsFactors=FALSE) # Define operators: Pars$edge[object$ram[,1]==2] <- "<->" Pars$edge[object$ram[,1]==1] <- "~>" # Pars$op[object$ram[,1]==1 & !Vars$manifest[match(Pars$lhs,Vars$name)] & Vars$manifest[match(Pars$rhs,Vars$name)]] <- "->" semModel <- new("semPlotModel") semModel@Pars <- Pars semModel@Vars <- Vars semModel@Computed <- TRUE semModel@Original <- list(object) semModel@ObsCovs <- list(object$S) semModel@ImpCovs <- list(object$C) return(semModel) } ### MUTLI GROUP MODEL ### semPlotModel.msem <- semPlotModel.msemObjectiveML <- function(object, ...) { nGroup <- length(object$ram) GroupNames <- object$groups ParsS <- list() stdobject <- standcoefmsem(object) for (g in 1:nGroup) { # Define Pars: Pars <- data.frame( label = rownames(object$ram[[g]]), lhs = object$ram[[g]][,3], edge = "", rhs = object$ram[[g]][,2], est = object$ram[[g]][,5], std = stdobject[[g]][,2], group = GroupNames[g], fixed = object$ram[[g]][,4]==0, par = object$ram[[g]][,4], stringsAsFactors=FALSE) # Extract parameter estimates: Pars$est[object$ram[[g]][,4]!=0] <- object$coef[object$ram[[g]][,4]] # Fix labels: for (i in unique(object$ram[[g]][,4][object$ram[[g]][,4]!=0])) { if (any(Pars$label[object$ram[[g]][,4]==i]=="") & any(Pars$label[object$ram[[g]][,4]==i]!="")) { Pars$label[object$ram[[g]][,4]==i & Pars$label==""] <- Pars$label[object$ram[[g]][,4]==i & Pars$label!=""] } } # Name variables: Pars$lhs <- object$var.names[[g]][Pars$lhs] Pars$rhs <- object$var.names[[g]][Pars$rhs] # Define operators: Pars$edge[object$ram[[g]][,1]==2] <- "<->" Pars$edge[object$ram[[g]][,1]==1] <- "->" ParsS[[g]] <- Pars } Pars <- do.call("rbind",ParsS) # Variable dataframe: Vars <- data.frame( name = unique(unlist(object$var.names)), manifest = unique(unlist(object$var.names)) %in% unique(c(sapply(object$S,colnames))), exogenous = NA, stringsAsFactors=FALSE) # Pars$op[object$ram[,1]==1 & !Vars$manifest[match(Pars$lhs,Vars$name)] & Vars$manifest[match(Pars$rhs,Vars$name)]] <- "->" semModel <- new("semPlotModel") semModel@Pars <- Pars semModel@Vars <- Vars semModel@Computed <- TRUE semModel@Original <- list(object) semModel@ObsCovs <- object$S semModel@ImpCovs <- object$C return(semModel) } semPlot/R/modelMatrices.R0000644000176200001440000001665414267410262015031 0ustar liggesusers# Function to extract parameters into model matrices: # Object is semPlotModel or can be created: # # Inner functions: # getRAMmodel <- function(object) # { # # # Parameters: # Nvar <- nrow(object@Vars) # Nman <- sum(object@Vars$manifest) # Names <- object@Vars$name # # # Empty matrices: # A <- S <- matrix(0,Nvar,Nvar) # F <- cbind(diag(1,Nman),matrix(0,Nman,Nvar-Nman)) # F[,order(object@Vars$manifest,decreasing=TRUE)] <- F # rownames(A) <- colnames(A) <- rownames(S) <- colnames(S) <- colnames(F) <- Names # rownames(F) <- Names[object@Vars$manifest] # # # Fill matrices: # for (i in seq_len(nrow(object@Pars))) # { # if (object@Pars$edge[i]=="<->") # { # S[which(Names==object@Pars$lhs[i])[1],which(Names==object@Pars$rhs[i])[1]] <- # S[which(Names==object@Pars$rhs[i])[1],which(Names==object@Pars$lhs[i])[1]] <- object@Pars$est[i] # } # if (object@Pars$edge[i]%in%c("->","~>")) # { # A[which(Names==object@Pars$rhs[i])[1],which(Names==object@Pars$lhs[i])[1]] <- object@Pars$est[i] # } # } # # Res <- list(A=A,S=S,F=F) # class(Res) <- "RAM" # return(Res) # } modelMatrices <- function(object,model="ram", endoOnly = FALSE) { # Check if input is combination of models: call <- paste(deparse(substitute(object)), collapse = "") if (grepl("\\+",call)) { args <- unlist(strsplit(call,split="\\+")) obs <- lapply(args,function(x)semPlotModel(eval(parse(text=x)))) object <- obs[[1]] for (i in 2:length(obs)) object <- object + obs[[i]] } if (!"semPlotModel"%in%class(object)) object <- semPlotModel(object) stopifnot("semPlotModel"%in%class(object)) ### SETUP ### Model <- list() class(Model) <- "semMatrixModel" # Define exogeneity: if (endoOnly) { object@Vars$exogenous <- FALSE } else { if (any(is.na(object@Vars$exogenous))) { object <- defExo(object) } } ### RAM MODEL ### if (grepl("ram",model,ignore.case=TRUE)) { # Extract names: man <- object@Vars$name[object@Vars$manifest] lat <- object@Vars$name[!object@Vars$manifest] all <- object@Vars$name # Extract matrices: Model[['A']] <- Pars2Matrix(object@Pars, c("->","~>"), all, all) Model[['S']] <- Pars2Matrix(object@Pars, "<->", all, all) Model[['F']] <- FilterMatrix(object@Pars, object@Vars) return(Model) } ### LISREL MODEL ###: if (grepl("lis",model,ignore.case=TRUE)) { # Extract names: manExo <- object@Vars$name[object@Vars$manifest & object@Vars$exogenous] manEndo <- object@Vars$name[object@Vars$manifest & !object@Vars$exogenous] latExo <- object@Vars$name[!object@Vars$manifest & object@Vars$exogenous] latEndo <- object@Vars$name[!object@Vars$manifest & !object@Vars$exogenous] # If any manifest var is used in regression, create dummy latents: if (any(object@Pars$lhs[object@Pars$edge%in%c("->","~>")] %in% c(manExo,manEndo))) { message("Latent dummy variables added to include manifest regressions") # Identify variables: manRegs <- c(manExo,manEndo)[c(manExo,manEndo)%in%object@Pars$lhs[object@Pars$edge%in%c("->","~>")]] newVars <- object@Vars[object@Vars$name %in% manRegs,] newVars$manifest <- FALSE newVars$name <- paste0(newVars$name,"@L@") object@Vars <- rbind(object@Vars,newVars) # Change regressions to latents: object@Pars$lhs[object@Pars$lhs %in% manRegs & object@Pars$edge%in%c("->","~>")] <- paste0(object@Pars$lhs[object@Pars$lhs %in% manRegs & object@Pars$edge%in%c("->","~>")],"@L@") manVarResids <- which(object@Pars$lhs %in% manRegs & object@Pars$rhs %in% manRegs & object@Pars$edge=="<->") object@Pars$lhs[manVarResids] <- paste0(object@Pars$lhs[manVarResids],"@L@") object@Pars$rhs[manVarResids] <- paste0(object@Pars$rhs[manVarResids],"@L@") # Add factor loadings: for (g in unique(object@Pars$group)) { parLocs <- nrow(object@Pars)+seq_along(manRegs) object@Pars[parLocs,"lhs"] <- paste0(manRegs,"@L@") object@Pars[parLocs,"rhs"] <- manRegs object@Pars[parLocs,"label"] <- "" object@Pars[parLocs,"est"] <- 1 object@Pars[parLocs,"std"] <- NA object@Pars[parLocs,"group"] <- g object@Pars[parLocs,"fixed"] <- TRUE object@Pars[parLocs,"par"] <- 0 } # Extract names: manExo <- object@Vars$name[object@Vars$manifest & object@Vars$exogenous] manEndo <- object@Vars$name[object@Vars$manifest & !object@Vars$exogenous] latExo <- object@Vars$name[!object@Vars$manifest & object@Vars$exogenous] latEndo <- object@Vars$name[!object@Vars$manifest & !object@Vars$exogenous] } # Extract matrices: Model[['LY']] <- Pars2Matrix(object@Pars, c("->","~>"), manEndo, latEndo) Model[['TE']] <- Pars2Matrix(object@Pars, "<->", manEndo, manEndo) Model[['PS']] <- Pars2Matrix(object@Pars, "<->", latEndo, latEndo) Model[['BE']] <- Pars2Matrix(object@Pars, c("->","~>"), latEndo, latEndo) Model[['LX']] <- Pars2Matrix(object@Pars, c("->","~>"), manExo, latExo) Model[['TD']] <- Pars2Matrix(object@Pars, "<->", manExo, manExo) Model[['PH']] <- Pars2Matrix(object@Pars, "<->", latExo, latExo) Model[['GA']] <- Pars2Matrix(object@Pars, c("->","~>"), latEndo, latExo) Model[['TY']] <- Pars2Matrix(object@Pars, "int", manEndo, "1") Model[['TX']] <- Pars2Matrix(object@Pars, "int", manExo, "1") Model[['AL']] <- Pars2Matrix(object@Pars, "int", latEndo, "1") Model[['KA']] <- Pars2Matrix(object@Pars, "int", latExo, "1") return(Model) } ### Mplus MODEL ###: if (grepl("mplus",model,ignore.case=TRUE)) { # Extract names (exo only if manifest has outgoing cons. error if in and outgoing): man <- object@Vars$name[object@Vars$manifest] lat <- object@Vars$name[!object@Vars$manifest] # Control input: if (any(sapply(man, function(m) any((object@Pars$lhs==m & object@Pars$edge %in% c("->","~>")) & (object@Pars$rhs==m & object@Pars$edge %in% c("->","~>")))))) stop("Manifest variable found with both incoming and outgoing edge. This is not yet supported in modelMatrices.") if (any(object@Pars$rhs %in% man & object@Pars$lhs %in% lat & object@Pars$edge == "~>")) { warning("Can not place regression (ON) from latent to manifest in a model matrix. Interpreted as factor loading (BY).") object@Pars$edge[object@Pars$rhs %in% man & object@Pars$lhs %in% lat & object@Pars$edge == "~>"] <- "->" } trueExo <- sapply(man, function(m) any((object@Pars$lhs==m & object@Pars$edge %in% c("->","~>")) & !(object@Pars$rhs==m & object@Pars$edge %in% c("->","~>")))) manEndo <- man[!trueExo] manExo <- man[trueExo] ## Extract matrices: # BY matrices: Model[['Nu']] <- Pars2Matrix(object@Pars, "int", manEndo, "1") Model[['Lambda']] <- Pars2Matrix(object@Pars, c("->","~>"), manEndo, lat) Model[['Theta']] <- Pars2Matrix(object@Pars, "<->", manEndo, manEndo) # ON matrices: Model[['Kappa']] <- Pars2Matrix(object@Pars, c("->","~>"), manEndo, manExo) Model[['Alpha']] <- Pars2Matrix(object@Pars, "int", lat, "1") Model[['Beta']] <- Pars2Matrix(object@Pars, c("->","~>"), lat, lat) Model[['Gamma']] <- Pars2Matrix(object@Pars, c("->","~>"), lat, manExo) Model[['Psi']] <- Pars2Matrix(object@Pars, "<->", lat, lat) return(Model) } else stop(paste("Model",model,"is not supported.")) }semPlot/R/OpenMx.R0000644000176200001440000002526214267410262013442 0ustar liggesusers### Path diagrams ### # # semPaths_MxRAMModel <- function(object,...){ # invisible(semPaths(semPlotModel(object),...)) # } # # semPaths_MxModel <- function(object,...){ # invisible(semPaths(semPlotModel(object),...)) # } # ### EXTRACT MODEL ### ### SINGLE GROUP ### semPlotModel_MxRAMModel <- function(object){ # Extract names: varNames <- object@manifestVars factNames <- object@latentVars if (!(length(varNames) || length(factNames))) stop(as.character(substitute(object)), '@manifestVars (and ', as.character(substitute(object)), '@latentVars if the model has ', 'latent variables) must contain variable names. You can set them ', 'using the manifestVars= and latentVars= arguments in mxModel().') # Standardized object: std <- OpenMx::mxStandardizeRAMpaths(object, SE = TRUE) # Extract directed paths: # Dirpaths <- which(t(object@matrices$A@free | object@matrices$A@values!=0),arr.ind=TRUE) # DirpathsFixed <- !t(object@matrices$A@free)[Dirpaths] # DirpathsValues <- t(object@matrices$A@values)[Dirpaths] # DirpathsLabels <- t(object@matrices$A@labels)[Dirpaths] # Extract symmetric paths: # Sympaths <- which(t(object@matrices$S@free | object@matrices$S@values!=0) & upper.tri(object@matrices$S@values,diag=TRUE),arr.ind=TRUE) # SympathsFixed <- !t(object@matrices$S@free)[Sympaths] # SympathsValues <- t(object@matrices$S@values)[Sympaths] # SympathsLabels <- t(object@matrices$A@labels)[Sympaths] # if (!is.null(object@matrices$M)) # { # # Extract intercepts: # Means <- which(object@matrices$M@free | object@matrices$M@values!=0) # MeansFixed <- !object@matrices$M@free[Means] # MeansValues <- object@matrices$M@values[Means] # MeansLabels <- object@matrices$M@labels[Means] # } else # { # Means <- numeric(0) # MeansFixed <- logical(0) # MeansValues <- numeric(0) # MeansLabels <- character(0) # } # # ## Standardized # if (!length(object@output)==0) # { # # browser() # # Function by Ryne Estabrook (http://openmx.psyc.virginia.edu/thread/718) # # standObj <- standardizeRAM(object,"model") # # # Extract directed paths: # # DirpathsValuesStd <- t(standObj@matrices$A@values)[Dirpaths] # # DirpathsValuesStd <- std$Std.Value[std$matrix=="A"] # # # Extract symmetric paths: # SympathsValuesStd <- t(standObj@matrices$S@values)[Sympaths] # # # Extract means: # #if (!is.null(standObj@matrices$M)) # { # MeansValuesStd <- standObj@matrices$S@values[Means] # } else { # MeansValuesStd <- numeric(0) # } # } else # { # DirpathsValuesStd <- rep(NA,nrow(Dirpaths)) # SympathsValuesStd <- rep(NA,nrow(Sympaths)) # MeansValuesStd <- rep(NA,length(Means)) # } # # Vars dataframe: Vars <- data.frame( name = c(varNames,factNames), manifest = c(varNames,factNames)%in%varNames, exogenous = NA, stringsAsFactors=FALSE) # standObj <- standardizeMx(object,free=T) # old semTools function, now in this file Edges <- std # Only edges in mats A and S: corMats <- Edges$matrix %in% c("A","S") # Define Pars: Pars <- data.frame( label = ifelse(is.na(Edges$label[corMats]),"",Edges$label[corMats]), lhs = Edges$col[corMats], edge = ifelse(Edges$matrix[corMats]=="A","->","<->"), rhs = Edges$row[corMats], est = Edges$Raw.Value[corMats], std = Edges$Std.Value[corMats], group = '', fixed = Edges$Raw.SE[corMats]==0, par = 0, stringsAsFactors=FALSE) # Maybe remove ints? if (!is.null(object@matrices$M)) { MeanStd <- c(object@matrices$M$values) ## in case labels are NA, use variable names if (!is.null(colnames(object@matrices$M$values))) { v.names <- colnames(object@matrices$M$values) v.idx <- v.names names(MeanStd) <- v.names } else { #FIXME? Warn users that this assumes order is {all manifest, all latent} v.names <- c(varNames, factNames) v.idx <- seq_along(v.names) } ## extract rows of std corresponding to the M matrix stdM <- std[std$matrix == "M", , drop = FALSE] ## loop over variable names that have a standardized estimate ## (only free parameters; assume others are fixed to zero) for (v in seq_along(stdM$col)) { MeanStd[ v.idx[v] ] <- stdM$Std.Value[stdM$col == v.idx[v] ] } ## old method (using deprecated semTools function, now at the bottom of this script) ## standardizeMx(object,free=T)[which(names(standardizeMx(object,free=T))%in%object@matrices$M$labels)] MeanEst <-data.frame( label = c(object@matrices$M$labels), ##### or, if they are NA, replace with variable names? # label = ifelse(!is.na(object@matrices$M$labels), # yes = object@matrices$M$labels, # no = v.names), lhs = '', rhs = v.names, edge = 'int', est = c(object@matrices$M$values), std = MeanStd, group = '', fixed = c(!object@matrices$M$free), par = 0, stringsAsFactors = FALSE ) Pars <- rbind(Pars,MeanEst) } Pars$par[is.na(Pars$label)] <- seq_len(sum(is.na(Pars$label))) for (lbl in unique(Pars$label[!is.na(Pars$label)])) { Pars$par[Pars$label==lbl] <- max(Pars$par)+1 } # # # Add standardized: # for (i in 1:nrow(standPars)) # { # if (standPars$matrix[i] == "A") # { # Pars$std[Pars$lhs == standPars$col[i] & Pars$rhs == standPars$row[i] & Pars$edge == "->"] <- standPars[["Std. Estimate"]][i] # } # if (standPars$matrix[i] == "S") # { # Pars$std[Pars$lhs == standPars$col[i] & Pars$rhs == standPars$row[i] & Pars$edge == "<->"] <- standPars[["Std. Estimate"]][i] # } # } Pars$label[is.na(Pars$label)] <- "" semModel <- new("semPlotModel") semModel@Pars <- Pars semModel@Vars <- Vars semModel@Computed <- !length(object@output)==0 semModel@Original <- list(object) if (!is.null(object@data)) { if (object@data@type=="cov") { semModel@ObsCovs <- list(object@data@observed) } else if (object@data@type=="raw") { semModel@ObsCovs <- list(cov(object@data@observed)) } else { semModel@ObsCovs <- list(NULL) } } else { semModel@ObsCovs <- list(NULL) } semModel@ImpCovs <- list(object@fitfunction@info$expCov) return(semModel) } semPlotModel_MxModel <- function(object){ if (any(!"MxRAMModel"%in%sapply(object@submodels,class))) stop("Model or all submodels must be of class 'MxRAMModel'") for (i in 1:length(object@submodels)) object@submodels[[i]]@output <- list(TRUE) S4objects <- lapply(object@submodels,semPlotModel) semModel <- new("semPlotModel") semModel@Pars <- do.call("rbind",lapply(S4objects,slot,"Pars")) semModel@Pars$par <- 0 semModel@Pars$par[semModel@Pars$label==""] <- seq_len(sum(semModel@Pars$label=="")) for (lbl in unique(semModel@Pars$label[semModel@Pars$label!=""])) { semModel@Pars$par[semModel@Pars$label==lbl] <- max(semModel@Pars$par)+1 } semModel@Vars <- S4objects[[1]]@Vars semModel@Computed <- !length(object@output)==0 semModel@Original <- list(object) semModel@ObsCovs <- lapply(S4objects,function(x)x@ObsCovs[[1]]) names(semModel@ObsCovs) <- sapply(object@submodels,slot,"name") semModel@ImpCovs <- lapply(S4objects,function(x)x@ImpCovs[[1]]) names(semModel@ImpCovs) <- sapply(object@submodels,slot,"name") return(semModel) } ## ----------------------------------------------------------------- ## semTools function (no longer used, but can be borrowed if needed) ## ----------------------------------------------------------------- standardizeMx <- function(object, free = TRUE) { .Deprecated(msg = c("The standardizeMx function is deprecated, and it will", " cease to be included in future versions of semTools.", " See help('semTools-deprecated) for details.")) # objectOrig <- object multigroup <- length(object@submodels) > 0 if(multigroup) { defVars <- lapply(object@submodels, findDefVars) defVars <- do.call(c, defVars) } else { defVars <- findDefVars(object) } if(length(defVars) > 0) stop("The standardizeMx is not available for the model with definition variable.") if(multigroup) { object@submodels <- lapply(object@submodels, standardizeMxSingleGroup) } else { object <- standardizeMxSingleGroup(object) } vectorizeMx(object, free=free) } ## Hidden functions findDefVars <- function(object) { ## borrowed from OpenMx::imxIsDefinitionVariable imxSeparatorChar <- "." imxIsDefinitionVariable <- function (name) { if (is.na(name)) { return(FALSE) } components <- unlist(strsplit(name, imxSeparatorChar, fixed = TRUE)) if (length(components) == 2 && components[[1]] == "data") { return(TRUE) } else if (length(components) > 2 && components[[2]] == "data") { return(TRUE) } else { return(FALSE) } } ## end borrowed code mat <- lapply(object@matrices, slot, "labels") defvars <- sapply(mat, function(x) x[apply(x, c(1,2), imxIsDefinitionVariable)]) Reduce("c", defvars) } vectorizeMx <- function(object, free = TRUE) { multigroup <- length(object@submodels) > 0 if(multigroup) { object <- object@submodels } else { object <- list(object) } result <- NULL for(i in seq_along(object)) { name <- "" if(multigroup) name <- paste0(object[[i]]@name, ".") mat <- object[[i]]@matrices for(j in seq_along(mat)) { tempname <- paste0(name, mat[[j]]@name) lab <- mat[[j]]@labels tempfree <- as.vector(mat[[j]]@free) madeLab <- paste0(tempname, "[", row(lab), ",", col(lab), "]") lab <- as.vector(lab) madeLab[!is.na(lab)] <- lab[!is.na(lab)] if(!free) tempfree <- rep(TRUE, length(tempfree)) temp <- mat[[j]]@values[tempfree] names(temp) <- madeLab[tempfree] result <- c(result, temp) } } result[!duplicated(names(result))] } standardizeMxSingleGroup <- function(object) { if (!is(object@expectation, "MxExpectationRAM")) stop("The standardizeMx function is available for the MxExpectationRAM only.") A <- object@matrices$A@values I <- diag(nrow(A)) S <- object@matrices$S@values # F <- object@matrices$F@values Z <- solve(I - A) impliedCov <- Z %*% S %*% t(Z) temp <- sqrt(diag(impliedCov)) if (length(temp) == 1) { ImpliedSd <- as.matrix(temp) } else { ImpliedSd <- diag(temp) } ImpliedInvSd <- solve(ImpliedSd) object@matrices$S@values <- ImpliedInvSd %*% S %*% ImpliedInvSd object@matrices$A@values <- ImpliedInvSd %*% A %*% ImpliedSd if (!is.null(object@matrices$M)) { M <- object@matrices$M@values object@matrices$M@values <- M %*% ImpliedInvSd } object } semPlot/R/semPathsHelperFuns.R0000644000176200001440000000733414267410262016014 0ustar liggesusers ## Mode function: Mode <- function(x) { ux <- unique(x) ux[which.max(tabulate(match(x, ux)))] } # Function to scale and rotate layouts: LayoutScaler <- function(x, xrange=1, yrange=1) { if ((max(x[,1]) - min(x[,1])) == 0) x[,1] <- mean(xrange) else x[,1] <- (x[,1] - min(x[,1])) / (max(x[,1]) - min(x[,1])) * 2 - 1 if ((max(x[,2]) - min(x[,2])) == 0) x[,2] <- mean(yrange) else x[,2] <- (x[,2] - min(x[,2])) / (max(x[,2]) - min(x[,2])) * 2 - 1 x[,1] <- x[,1] * xrange x[,2] <- x[,2] * yrange return(x) } # Rotation function: RotMat <- function(d,w2hrat=1) { matrix(c(cos(-d),sin(-d),-sin(-d),cos(-d)),2,2) } ## Function to compute reingold-tilford layout using igraph: rtLayout <- function(roots,GroupPars,Edgelist,layout,exoMan) { # Reverse intercepts in graph: # revNodes <- which((GroupPars$edge == "int" | Edgelist[,2] %in% exoMan) & !Edgelist[,1] %in% roots ) # revNodes <- which((GroupPars$edge == "int" & !Edgelist[,1] %in% roots) | Edgelist[,2] %in% exoMan ) # Edgelist[revNodes,1:2] <- Edgelist[revNodes,2:1] # Remove double headed arrows: Edgelist <- Edgelist[GroupPars$edge != "<->",] # Make igraph object: Graph <- graph.edgelist(Edgelist, FALSE) # Compute layout: Layout <- layout.reingold.tilford(Graph,root=roots,circular = FALSE) return(Layout) } ## Function to mix color vector x with weight w mixColfun <- function(x,w) { # x = vector of colors # w = weights if (missing(w)) w <- rep(1,length(x)) if (length(w)==1) w <- rep(w,length(x)) ## w == 0 leads to NaN from weighted.mean() w[w <= 0] <- 0.0000001 RGB <- col2rgb(x) wMeans <- apply(RGB,1,weighted.mean,w=w) return(rgb(wMeans[1],wMeans[2],wMeans[3],maxColorValue=255)) } loopOptim <- function(x,Degrees) { NotinRange <- sum(sapply(Degrees,function(d)!any(c(d,d-2*pi,d+2*pi)>(x-pi/4) & c(d,d-2*pi,d+2*pi)<(x+pi/4)))) Dist2Edges <- sapply(Degrees,function(d)min(abs(x - c(d,d-2*pi,d+2*pi)))) return(NotinRange * 2 * pi * 2 + sum(sort(Dist2Edges)[1:2])) } # RotMat <- function(d) matrix(c(cos(-d),sin(-d),-sin(-d),cos(-d)),2,2) mixInts <- function(vars,intMap,Layout,trim=FALSE,intAtSide=TRUE) { n <- length(vars) if (intAtSide) { if (!trim) { if (n+nrow(intMap)==1) { sq <- 0 } if (n+nrow(intMap) == 2) { sq <- c(0,0.5) } else { sq <- seq(-1,1,length=n+nrow(intMap)) } } else { if (n+nrow(intMap) == 2) { sq <- c(0,0.5) } else { sq <- seq(-1,1,length=n+nrow(intMap)+2)[-c(1,n+nrow(intMap)+2)] } } cent <- median(1:n) c <- 1 for (i in seq_along(vars)) { if (vars[i]%in%intMap[,2]) { if (i < cent) { Layout[intMap[intMap[,2]==vars[i],1],1] <- sq[c] Layout[vars[i],1] <- sq[c+1] c <- c+2 } else { Layout[intMap[intMap[,2]==vars[i],1],1] <- sq[c+1] Layout[vars[i],1] <- sq[c] c <- c+2 } } else { Layout[vars[i],1] <- sq[c] c <- c+1 } } } else { if (!trim) { if (n==1) { sq <- 0 } else if (n == 2) { sq <- c(-1,1) } else { sq <- seq(-1,1,length=n) } } else { if (n == 1) { sq <- 0 } else if (n == 2) { sq <- c(-0.5,0.5) } else { sq <- seq(-1,1,length=n+2)[-c(1,n+2)] } } c <- 1 for (i in seq_along(vars)) { if (vars[i]%in%intMap[,2]) { Layout[intMap[intMap[,2]==vars[i],1],1] <- sq[c] Layout[vars[i],1] <- sq[c] c <- c + 1 } else { Layout[vars[i],1] <- sq[c] c <- c+1 } } } return(Layout) } semPlot/R/lavaan.R0000644000176200001440000000721514267410262013474 0ustar liggesusers### Path diagrams ### # # setMethod("semPaths.S4",signature("lavaan"),function(object,...){ # invisible(semPaths(semPlotModel(object),...)) # }) # ## EXTRACT MODEL ### setMethod("semPlotModel_S4",signature("lavaan"),function(object){ if (is(object,"blavaan")) class(object) <- 'lavaan' if (!is(object,"lavaan")) stop("Input must me a 'lavaan' object") # Extract parameter estimates: pars <- parameterEstimates(object,standardized=TRUE) list <- inspect(object,"list") # Remove mean structure (TEMP SOLUTION) # meanstructure <- pars$op=="~1" # pars <- pars[!meanstructure,] # Extract variable and factor names: # varNames <- fit@Model@dimNames$lambda[[1]] # factNames <- fit@Model@dimNames$lambda[[2]] # Lambda <- inspect(object,"coef")$lambda varNames <- lavaanNames(object, type="ov") factNames <- lavaanNames(object, type="lv") # rm(Lambda) factNames <- factNames[!factNames%in%varNames] # Extract number of variables and factors n <- length(varNames) k <- length(factNames) # Extract parameter names: if (is.null(pars$label)) pars$label <- rep("",nrow(pars)) semModel <- new("semPlotModel") if (is.null(pars$group)) pars$group <- "" # Create edges dataframe semModel@Pars <- data.frame( label = pars$label, lhs = ifelse(pars$op=="~"|pars$op=="~1",pars$rhs,pars$lhs), edge = "--", rhs = ifelse(pars$op=="~"|pars$op=="~1",pars$lhs,pars$rhs), est = pars$est, std = pars$std.all, group = pars$group, fixed = list$free[list$op!="=="]==0, par = list$free[list$op!="=="], stringsAsFactors=FALSE) semModel@Pars$edge[pars$op=="~~"] <- "<->" semModel@Pars$edge[pars$op=="~*~"] <- "<->" semModel@Pars$edge[pars$op=="~"] <- "~>" semModel@Pars$edge[pars$op=="=~"] <- "->" semModel@Pars$edge[pars$op=="~1"] <- "int" semModel@Pars$edge[grepl("\\|",pars$op)] <- "|" # Move thresholds to Thresholds slot: semModel@Thresholds <- semModel@Pars[grepl("\\|",semModel@Pars$edge),-(3:4)] # Remove constraints and weird stuff: semModel@Pars <- semModel@Pars[!pars$op %in% c('<', '>',':=','<','>','==','|'),] # Remove thresholds from Pars: # semModel@Pars <- semModel@Pars[!grepl("\\|",semModel@Pars$edge),] semModel@Vars <- data.frame( name = c(varNames,factNames), manifest = c(varNames,factNames)%in%varNames, exogenous = NA, stringsAsFactors=FALSE) # res.cov <- lavTech(object, "sampstat")$res.cov # lavTech(object, "sampstat")$cov # if (!is.null(res.cov) && !length(res.cov) == 0){ # if (!is.null(res.cov[[1]])){ # semModel@ObsCovs <- object@SampleStats@res.cov # } else { # semModel@ObsCovs <- object@SampleStats@cov # } # } else { # semModel@ObsCovs <- list(matrix(NA, # length(varNames),length(varNames))) # } if (lavInspect(object, "options")$conditional.x){ semModel@ObsCovs <- lapply(lavTech(object, "sampstat"),"[[","res.cov") } else { semModel@ObsCovs <- lapply(lavTech(object, "sampstat"),"[[","cov") } names(semModel@ObsCovs) <- lavInspect(object, "group.label") for (i in 1:length(semModel@ObsCovs)) { rownames(semModel@ObsCovs[[i]]) <- colnames(semModel@ObsCovs[[i]]) <- lavaanNames(object, type="ov") #object@Data@ov.names[[i]] } semModel@ImpCovs <- lapply(lavTech(object, "implied"), "[[", "cov") names(semModel@ImpCovs) <- lavInspect(object, "group.label") # object@Data@group.label for (i in 1:length(semModel@ImpCovs)) { rownames(semModel@ImpCovs[[i]]) <- colnames(semModel@ImpCovs[[i]]) <- lavaanNames(object, type="ov") } semModel@Computed <- TRUE semModel@Original <- list(object) return(semModel) }) semPlot/R/operators.R0000644000176200001440000000131314267410262014241 0ustar liggesusers# Add function: '+.semPlotModel' <- function(x,y) { stopifnot("semPlotModel"%in%class(x)) stopifnot("semPlotModel"%in%class(y)) # Update par in y: y@Pars$par[y@Pars$par>0] <- max(x@Pars$par) + y@Pars$par[y@Pars$par>0] # New model: semModel <- new("semPlotModel") semModel@Pars <- rbind(x@Pars,y@Pars) semModel@Vars <- rbind(x@Vars,y@Vars) semModel@Vars <- semModel@Vars[!duplicated(semModel@Vars),] semModel@Thresholds <- rbind(x@Thresholds,y@Thresholds) semModel@Computed <- x@Computed && y@Computed semModel@Original <- list(x@Original[[1]],y@Original[[1]]) semModel@ObsCovs <- c(x@ObsCovs,y@ObsCovs) semModel@ImpCovs <- c(x@ImpCovs,y@ImpCovs) # Return: return(semModel) }semPlot/R/Pars2Matrix.R0000644000176200001440000000476714267410262014417 0ustar liggesusers# Inner function, computes matrix from Pars subsection: # Pars: Sub of Pars # rows: Rownames # cols: Colnames # lhsisrow: lhs variable is interpreted as row (default to FALSE) Pars2Matrix <- function(Pars, edges, rows, cols, symmetrical, lhsisrow = FALSE) { if (missing(symmetrical)) { symmetrical <- any(grepl("<->",edges)) } if (lhsisrow) Pars[c('lhs','rhs')] <- Pars[c('rhs','lhs')] Groups <- unique(Pars$group) Pars$lhs[Pars$edge=="int"] <- "1" Pars <- Pars[Pars$edge %in% edges & Pars$lhs %in% cols & Pars$rhs %in% rows,] ResMatrix <- list() empMatrix <- matrix(0, length(rows), length(cols)) rownames(empMatrix) <- gsub("@L@","",rows) colnames(empMatrix) <- gsub("@L@","",cols) for (i in seq_along(Groups)) { GroupPars <- Pars[Pars$group == Groups[i],] ResMatrix[[i]] <- list() ResMatrix[[i]]$est <- empMatrix ResMatrix[[i]]$std <- empMatrix ResMatrix[[i]]$par <- empMatrix ResMatrix[[i]]$fixed <- empMatrix mode(ResMatrix[[i]]$fixed) <- "logical" for (j in seq_len(nrow(GroupPars))) { ResMatrix[[i]]$est[match(GroupPars$rhs[j],rows),match(GroupPars$lhs[j],cols)] <- GroupPars$est[j] ResMatrix[[i]]$std[match(GroupPars$rhs[j],rows),match(GroupPars$lhs[j],cols)] <- GroupPars$std[j] ResMatrix[[i]]$fixed[match(GroupPars$rhs[j],rows),match(GroupPars$lhs[j],cols)] <- GroupPars$fixed[j] ResMatrix[[i]]$par[match(GroupPars$rhs[j],rows),match(GroupPars$lhs[j],cols)] <- GroupPars$par[j] if (symmetrical) { ResMatrix[[i]]$est[match(GroupPars$lhs[j],rows),match(GroupPars$rhs[j],cols)] <- GroupPars$est[j] ResMatrix[[i]]$std[match(GroupPars$lhs[j],rows),match(GroupPars$rhs[j],cols)] <- GroupPars$std[j] ResMatrix[[i]]$fixed[match(GroupPars$lhs[j],rows),match(GroupPars$rhs[j],cols)] <- GroupPars$fixed[j] ResMatrix[[i]]$par[match(GroupPars$lhs[j],rows),match(GroupPars$rhs[j],cols)] <- GroupPars$par[j] } } } names(ResMatrix) <- Groups return(ResMatrix) } FilterMatrix <- function(Pars, Vars) { Groups <- unique(Pars$group) ResMatrix <- list() Nvar <- nrow(Vars) Nman <- sum(Vars$manifest) for (i in seq_along(Groups)) { ResMatrix[[i]] <- list() ResMatrix[[i]]$est <- cbind(diag(1,Nman),matrix(0,Nman,Nvar-Nman)) ResMatrix[[i]]$est[,order(Vars$manifest,decreasing=TRUE)] <- ResMatrix[[i]]$est rownames(ResMatrix[[i]]$est) <- Vars$name[Vars$manifest] colnames(ResMatrix[[i]]$est) <- Vars$name } names(ResMatrix) <- Groups return(ResMatrix) }semPlot/R/onyx.R0000644000176200001440000000336314267410262013227 0ustar liggesusers semPlotModel_Onyx <- function(object) { # Parse Onyx model: doc <- xmlParse(object) # Get Nodes and Edges: Nodes <- getNodeSet(doc, "/model/graph/node") Edges <- getNodeSet(doc, "/model/graph/edge") Const <- as.logical(sapply(Nodes, function(n) xmlGetAttr(n, "constant"))) # Get NodeNames: NodeNames <- sapply(Nodes, function(n) xmlGetAttr(n, "caption")) NodeNames[Const] <- "" # Get edgelist: Edgelist <- data.frame( From = as.numeric(as.character(sapply(Edges, function(n) xmlGetAttr(n, "sourceNodeId")))), To = as.numeric(as.character(sapply(Edges, function(n) xmlGetAttr(n, "targetNodeId")))), stringsAsFactors=FALSE) + 1 # Define Pars: Pars <- data.frame( label = sapply(Edges, function(n) xmlGetAttr(n, "parameterName")), lhs = NodeNames[Edgelist$From], edge = ifelse(as.logical(sapply(Edges, function(n) xmlGetAttr(n, "doubleHeaded"))),"<->","->"), rhs = NodeNames[Edgelist$To], est = as.numeric(as.character(sapply(Edges, function(n) xmlGetAttr(n, "value")))), std = NA, group = "", fixed = as.logical(sapply(Edges, function(n) xmlGetAttr(n, "fixed"))), par = 0, stringsAsFactors=FALSE) Pars$edge[Pars$lhs==""] <- "int" Pars$par <- 1:nrow(Pars) # Vars: Vars <- data.frame( name = NodeNames, manifest = !as.logical(sapply(Nodes, function(n) xmlGetAttr(n, "latent"))), exogenous = NA, stringsAsFactors=FALSE) Vars <- Vars[c(which(Vars$manifest),which(!Vars$manifest)),] # Return: semModel <- new("semPlotModel") semModel@Pars <- Pars semModel@Vars <- Vars semModel@Computed <- FALSE semModel@Original <- list(doc) semModel@ObsCovs <- list() semModel@ImpCovs <- list() # semModel@Thresholds <- Thresh return(semModel) }semPlot/R/lisrelMat2RAM.R0000644000176200001440000000250714267410262014607 0ustar liggesusersmodMat2Pars <- function(x,edge,exprname,symmetric=FALSE,vec=FALSE,cols,rows,group="",exprsup="") { # Define x Pars: if (length(x)>0) { if (symmetric) { if (!isSymmetric(x$est)) stop(paste0("'",deparse(substitute(x)),"' matrix must be symmetrical.")) x$est[upper.tri(x$est)] <- 0 } Pars <- data.frame( label = "", lhs = rep(cols,each=length(rows)), edge = edge, rhs = rep(rows,times=length(cols)), est = c(x$est), std = NA, group = group, fixed = FALSE, par = 0, stringsAsFactors=FALSE) if (!vec) { Pars$label <- c(outer(1:nrow(x$est),1:ncol(x$est),function(x,y)paste0(exprname,"[",x,y,"]",exprsup))) } else { Pars$label <- paste0(exprname,"[",1:length(x$est),"]",exprsup) } if (!is.null(x[['std']])) { Pars[['std']] <- c(x[['std']]) } if (!is.null(x[['par']])) { Pars[['par']] <- c(x[['par']]) } if (!is.null(x[['fixed']])) { Pars[['fixed']] <- c(x[['fixed']]) } } else Pars <- data.frame( label = character(0), lhs = character(0), edge = character(0), rhs = character(0), est = numeric(0), std = numeric(0), group = character(0), fixed = logical(0), par = numeric(0), stringsAsFactors=FALSE) return(Pars) } semPlot/R/lists.R0000644000176200001440000000101114267410262013354 0ustar liggesusers semPlotModel.list <- function(object,...) { if ("mplus.model"%in%class(object)) return(semPlotModel.mplus.model(object,...)) mod <- try(semPlotModel_lavaanModel(object,...),silent=TRUE) if (!"try-error"%in%class(mod)) return(mod) isModel <- sapply(object,function(x)"semPlotModel"%in%class(x)) object[!isModel] <- lapply(object[!isModel],semPlotModel) if (length(object)>1) { Res <- object[[1]] for (i in 2:length(object)) Res <- Res + object[[i]] return(Res) } else return(object) } semPlot/R/glm.R0000644000176200001440000000367414267410262013016 0ustar liggesusers semPlotModel.lm <- function(object, ...) { coef <- as.matrix(coef(object)) Nr <- nrow(coef) Nc <- ncol(coef) combLetters <- function(x) { if (length(x)>1) return(sapply(x,combLetters)) f <- function(x) { if (x[1]>26) c(f(floor(x/26)),x%%26 + 1) else x } paste(LETTERS[f(x)],collapse="") } if (is.null(rownames(coef))) { rownames(coef) <- names(object$model)[(Nc+1):length(object$model)] } if (is.null(colnames(coef))) { colnames(coef) <- names(object$model)[1:Nc] } namesCoef <- rownames(coef) stdCoef <- coef(standardize(object)) names(stdCoef) <- gsub("`","",names(stdCoef)) NamesR <- rownames(coef) NamesC <- colnames(coef) Pars <- data.frame( label = "", lhs = rep(NamesR,times=Nc), edge = "->", rhs = rep(NamesC,each=Nr), est = c(coef), std = unname(c(stdCoef[paste0(namesCoef,"s")])), group = "", fixed = FALSE, par = 1:(Nr*Nc), knot = 0, stringsAsFactors=FALSE) ## Split interactions: if (any(grepl(":",Pars$lhs))) { colons <- grep(":",Pars$lhs) for (i in seq_along(colons)) { labs <- strsplit(Pars$lhs[colons[i]],split=":")[[1]] Pars$lhs[colons[i]] <- labs[1] Pars$knot[colons[i]] <- i for (j in 2:length(labs)) { Pars <- rbind(Pars,Pars[colons[i],]) Pars$lhs[nrow(Pars)] <- labs[j] } } } Pars$edge[grepl("intercept",Pars$lhs,ignore.case=TRUE)] <- "int" Pars$lhs[grepl("intercept",Pars$lhs,ignore.case=TRUE)] <- "" # Variable dataframe: Vars <- data.frame( name = unique(c(Pars$lhs,Pars$rhs)), manifest = TRUE, exogenous = NA, stringsAsFactors=FALSE) Vars <- Vars[Vars$name!="",] semModel <- new("semPlotModel") semModel@Pars <- Pars semModel@Vars <- Vars semModel@Computed <- TRUE semModel@Original <- list(object) semModel@ObsCovs <- list() semModel@ImpCovs <- list() return(semModel) }semPlot/R/semspec.R0000644000176200001440000000571514267410262013674 0ustar liggesusers## This function is commented out because semspec is not yet on CRAN. For the full version of this function please see ## www.sachaepskamp.com/semPlot semPlotModel.semspec <- function(object) { stop("This function is not included in the CRAN release because semspec is not on CRAN. Please see www.sachaepskamp.com for the function") # # # Load 'semspec': # if (!require("semspec")) stop('semspec is required: install.packages("semspec", repos="http://R-Forge.R-project.org")') # # semreprObject <- semrepr(object) # sumObject <- summary(object) # # # Define Pars: # Pars <- data.frame( # label = "", # lhs = semreprObject$lhs, # edge = "--", # rhs = semreprObject$rhs, # est = NA, # std = NA, # group = ifelse(is.na(semreprObject$group),"",semreprObject$group), # fixed = FALSE, # par = 0, # stringsAsFactors=FALSE) # # # Label: # if (!is.null(semreprObject$param)) Pars$label <- semreprObject$param # # # # Fixed: # # if (!is.null(semreprObject$free)) Pars$fixed <- !semreprObject$free # if (length(sumObject$constraints$details$Constraint)>0) # { # spl <- strsplit(sumObject$constraints$details$Constraint,split=" == ")[grepl("==",sumObject$constraints$details$Constraint)] # parNum <- sapply(spl,function(x)sum(x%in%Pars$label)) # parIt <- 1 # for (p in 1:length(spl)) # { # if (parNum[p]==1) # { # Pars$fixed[Pars$label%in%spl[[p]]] <- TRUE # } else if (parNum[p]==2) # { # Pars$par[Pars$label%in%spl[[p]]] <- parIt # parIt <- parIt + 1 # } else warning("Error in computation of equality constraints.") # } # } # # if (max(Pars$par) < nrow(Pars)) # { # Pars$par[Pars$par==0] <- max(Pars$par)+(1:sum(Pars$par==0)) # } # # # Extract parameter estimates: # Pars$est[object$ram[,4]!=0] <- object$coef[object$ram[,4]] # # # Switch sides in regression: # Pars[c("lhs","rhs")][semreprObject$type=="regression",] <- Pars[c("rhs","lhs")][semreprObject$type=="regression",] # # # Set edges: # Pars$edge[semreprObject$type=="regression"] <- "~>" # Pars$edge[semreprObject$type=="latent"] <- "->" # Pars$edge[semreprObject$type=="covariance"] <- "<->" # Pars$edge[semreprObject$type=="intercept"] <- "int" # # # Variable dataframe: # Vars <- data.frame( # name = sumObject$variables$details$Variable, # manifest = sumObject$variables$details$Type == "Manifest", # exogenous = NA, # stringsAsFactors=FALSE) # # # If all are latent, make guess at which are latent: # if (all(!Vars$manifest)) # { # for (i in 1:nrow(Vars)) # { # Vars$manifest[i] <- !any(semreprObject$type[semreprObject$lhs==Vars$name[i]]=="latent") # } # } # # semModel <- new("semPlotModel") # semModel@Pars <- Pars # semModel@Vars <- Vars # semModel@Computed <- FALSE # semModel@Original <- list() # semModel@ObsCovs <- list() # semModel@ImpCovs <- list() # # return(semModel) } semPlot/R/Imin.R0000644000176200001440000000171214267410262013122 0ustar liggesusersImin <- function(x,inverse=FALSE) { if (any(dim(x)==0)) { return(array(0,dim=dim(x))) } else { x <- diag(1,nrow(x),ncol(x)) - x if (inverse) { res <- tryCatch(solve(x), error = function(e) FALSE, silent = TRUE) if (is.matrix(res)) return(res) else { res <- tryCatch(pseudoinverse(x), error = function(e) FALSE, silent = TRUE) if (is.matrix(res)) { warning("Psuedoinverse used for singular matrix. Standardized solution might not be proper.") return(res) } else { warning("Uninvertable matrix found and psuedoinverse could not be computed. Standardized solutions probably not proper.") return(array(0, dim=dim(x))) } } } else { res <- x } if (is.matrix(res)) return(res) else { warning("Uninvertable matrix found. Standardized solutions are not proper.") return(array(0, dim=dim(x))) } } } semPlot/R/regsemplot.R0000644000176200001440000000565214267410262014416 0ustar liggesusers semPlotModel.regsem <- semPlotModel.regsemplot <- function(object,...){ ## Save parts of the output in objects object1 <- object$lav.model@ParTable # parameters object2 <- object$lav.model@Model@dimNames # variable names varnames <- unique(c(object1$lhs, object1$rhs)) # all names mannames <- object2[[1]][1] # manifest variables names(mannames) <- 'manifest' '%!in%' <- function(x,y)!('%in%'(x,y)) ## Add the fixed relations to the parameter estimates of regsem namelist <- strsplit(names(object$out$pars)," ") # split names and operators inout <- data.frame(1,2) for(i in 1:length(namelist)){ inout[i,1] <- namelist[[i]][1] inout[i,2] <- namelist[[i]][3] } # create data frame of regsem variables int <- data.frame(1,2) for(i in 1:length(object1$lhs)){ int[i,1] <- ifelse(object1$op[i]=="~"|object1$op[i]=="~1",object1$rhs[i],object1$lhs[i]) int[i,2] <- ifelse(object1$op[i]=="~"|object1$op[i]=="~1",object1$lhs[i],object1$rhs[i]) } # create data frame of lavaan variables ## Paste together pinout <- with(inout, paste0(X1, X2)) pint <- with(int, paste0(X1, X2)) counter <- 0 for(i in 1:length(pint)){ if(pint[i] %!in% pinout){ object1$regest[i] <- 1 counter <- counter + 1 } else { object1$regest[i] <- object$out$pars[i - counter] } } # match regsem estimates with lavaan variables, set fixed to 1 ## Create a S4 list semModel <- new("semPlotModel") ## Create a Pars data frame semModel@Pars <- data.frame( label = rep("", length(object1$id)), lhs = ifelse(object1$op=="~"|object1$op=="~1",object1$rhs,object1$lhs), # first went from left to right without checking relationship edge = "--", rhs = ifelse(object1$op=="~"|object1$op=="~1",object1$lhs,object1$rhs), est = object1$regest, # check if we should take estimates from other model, if estimates are same as in regsem std = NA, group = object1$group, fixed = object1$free == 0, par = object1$free, stringsAsFactors=FALSE) row.names(semModel@Pars) <- 1:length(object1$id) ## translate operators semModel@Pars$edge[object1$op=="~~"] <- "<->" semModel@Pars$edge[object1$op=="~*~"] <- "<->" semModel@Pars$edge[object1$op=="~"] <- "~>" semModel@Pars$edge[object1$op=="=~"] <- "->" semModel@Pars$edge[object1$op=="~1"] <- "int" semModel@Pars$edge[grepl("\\|",object1$op)] <- "|" semModel@Pars <- semModel@Pars[!object$op%in%c(':=','<','>','==','|','<', '>'),] ## Create a vars data frame semModel@Vars <- data.frame( name = varnames, manifest = varnames[1:length(varnames)] %in% mannames$manifest[1:length(mannames$manifest)], exogenous = NA, stringsAsFactors = FALSE ) ## Miscellaneous data frames semModel@Thresholds <- data.frame() semModel@ObsCovs <- list() semModel@ImpCovs <- list() semModel@Computed <- FALSE semModel@Original <- list(object) return(semModel) } semPlot/R/semMatrixAlgebra.R0000644000176200001440000000306614267410262015461 0ustar liggesuserssemMatrixAlgebra <- function(object, algebra, group, simplify = TRUE, model, endoOnly = FALSE) { # Check if input is combination of models: call <- paste(deparse(substitute(object)), collapse = "") if (grepl("\\+",call)) { args <- unlist(strsplit(call,split="\\+")) obs <- lapply(args,function(x)semPlotModel(eval(parse(text=x)))) object <- obs[[1]] for (i in 2:length(obs)) object <- object + obs[[i]] } if ("lisrel"%in%class(object)) object <- object$matrices if (!"semMatrixModel"%in%class(object)) { if (missing(model)) { if (any(grepl("(LY)|(TE)|(PS)|(BE)|(LX)|(TD)|(PH)|(GA)|(TY)|(TX)|(AL)|(KA)",deparse(substitute(algebra))))) { model <- "lisrel" message("model set to 'lisrel'") } else if (any(grepl("(Lambda)|(Nu)|(Theta)|(Kappa)|(Alpha)|(Beta)|(Gamma)|(Psi)",deparse(substitute(algebra))))) { model <- "mplus" message("model set to 'mplus'") } else if (any(grepl("A|S|F",deparse(substitute(algebra))))) { model <- "ram" message("model set to 'ram'") } else stop("'model' could not be detected") } object <- modelMatrices(object,model,endoOnly = endoOnly) } stopifnot("semMatrixModel"%in%class(object)) if (missing(group)) group <- seq_len(max(sapply(object,length))) Mats <- lapply(object,lapply,'[[','est') Res <- list() for (i in seq_along(group)) { GroupMats <- lapply(Mats,'[[',i) Res[[i]] <- eval(substitute(algebra), GroupMats) } if (simplify) if (length(Res)==1) Res <- Res[[1]] return(Res) }semPlot/R/lavaanModel.R0000644000176200001440000000430614267410262014453 0ustar liggesusers### Path diagrams ### # # setMethod("semPaths.S4",signature("lavaan"),function(object,...){ # invisible(semPaths(semPlotModel(object),...)) # }) # ## EXTRACT MODEL ### semPlotModel_lavaanModel <- function(object, ...) { # Check if parTable, otherwise run lavaanify: if (!is.data.frame(object) & !is.list(object)) { object <- lavaanify(object, ...) } varNames <- lavaanNames(object, type="ov") factNames <- lavaanNames(object, type="lv") # rm(Lambda) factNames <- factNames[!factNames%in%varNames] # Extract number of variables and factors n <- length(varNames) k <- length(factNames) # Extract parameter names: if (is.null(object$label)) object$label <- rep("",nrow(object)) semModel <- new("semPlotModel") # Set estimates to 1 or ustart: object$est <- ifelse(is.na(object$ustart),1,object$ustart) if (is.null(object$group)) object$group <- "" # Create edges dataframe semModel@Pars <- data.frame( label = object$label, lhs = ifelse(object$op=="~"|object$op=="~1",object$rhs,object$lhs), edge = "--", rhs = ifelse(object$op=="~"|object$op=="~1",object$lhs,object$rhs), est = object$est, std = NA, group = object$group, fixed = object$free==0, par = object$free, stringsAsFactors=FALSE) semModel@Pars$edge[object$op=="~~"] <- "<->" semModel@Pars$edge[object$op=="~*~"] <- "<->" semModel@Pars$edge[object$op=="~"] <- "~>" semModel@Pars$edge[object$op=="=~"] <- "->" semModel@Pars$edge[object$op=="~1"] <- "int" semModel@Pars$edge[grepl("\\|",object$op)] <- "|" # Move thresholds to Thresholds slot: semModel@Thresholds <- semModel@Pars[grepl("\\|",semModel@Pars$edge),-(3:4)] # Remove thresholds from Pars: # semModel@Pars <- semModel@Pars[!grepl("\\|",semModel@Pars$edge),] # Remove weird edges: semModel@Pars <- semModel@Pars[!object$op%in%c(':=','<','>','==','|','<', '>'),] semModel@Vars <- data.frame( name = c(varNames,factNames), manifest = c(varNames,factNames)%in%varNames, exogenous = NA, stringsAsFactors=FALSE) semModel@ObsCovs <- list() semModel@ImpCovs <- list() semModel@Computed <- FALSE semModel@Original <- list(object) return(semModel) } semPlot/R/standardizeRAM_2.R0000644000176200001440000000611014267410262015314 0ustar liggesusers# function: standardizeRAM # author: Ryne Estabrook # date: 20 Oct 2010 # revised: 01 Nov 2010 (corrected algebra) # 13 Dec 2010 (corrected 'parameters' output) standardizeRAM <- function(model, return="parameters", Amat=NA, Smat=NA, Mmat=NA){ # make sure 'return' is valid if (!(return=="parameters"|return=="matrices"|return=="model"))stop("Invalid 'return' parameter. What do you want from me?") # get the name of the objective obj <- class(model@objective)[1] suppliedNames <- !is.na(Amat)&!is.na(Smat) cA <- is.character(Amat) cS <- is.character(Smat) cM <- is.character(Mmat) # if the objective function isn't RAMObjective, you need to supply Amat and Smat if (obj!="MxRAMObjective"&(!cA))stop("I need either mxRAMObjective or the names of the A and S matrices.") output <- model@output # stop if there is no objective function if (is.null(output))stop("Provided model has no objective function, and thus no output. I can only standardize models that have been run!") # stop if there is no output if (length(output)<1)stop("Provided model has no output. I can only standardize models that have been run!") # get the names of the A, S and M matrices if (cA){nA <- Amat} else {nA <- model@objective@A} if (cS){nS <- Smat} else {nS <- model@objective@S} if (cM){nM <- Mmat} else {nM <- model@objective@M} # get the actual A and S matrices, and make an identity matrix A <- model[[nA]] S <- model[[nS]] d <- dim(S@values)[1] I <- diag(d) # calculate the model expected covariance matrix IA <- solve(I-A@values) expCov <- IA %*% S@values %*% t(IA) # calculate 1/SDs and put them in a diagonal matrix invSDs <- 1/sqrt(diag(expCov)) # give the inverse SDs names, because mxSummary treats column names as characters names(invSDs) <- as.character(1:length(invSDs)) if (!is.null(dimnames(A@values))){names(invSDs) <- as.vector(dimnames(S@values)[[2]])} # put the inverse SDs into a diagonal matrix (might as well recycle my I matrix from above) diag(I) <- invSDs # standardize the A, S and M matrices # A paths are value*sd(from)/sd(to) = I %*% A %*% solve(I) # S paths are value/(sd(from*sd(to))) = I %*% S %*% I stdA <- I %*% A@values %*% solve(I) stdS <- I %*% S@values %*% I # populate the model model[[nA]]@values[,] <- stdA model[[nS]]@values[,] <- stdS if (!is.na(nM)){model[[nM]]@values[,] <- rep(0, length(invSDs))} # return the model, if asked if(return=="model")return(model) # return the matrices, if asked matrices <- list(model[[nA]], model[[nS]]) names(matrices) <- c("A", "S") if(return=="matrices")return(matrices) # else, return the parameters # let's rebuild the parameter list p <- summary(model)$parameters p <- p[(p[,2]==nA)|(p[,2]==nS),] ## get the rescaling factor # this is for the A matrix rescale <- invSDs[p$row] * 1/invSDs[p$col] # this is for the S matrix rescaleS <- invSDs[p$row] * invSDs[p$col] # put the A and the S together rescale[p$matrix=="S"] <- rescaleS[p$matrix=="S"] # rescale p[,5] <- p[,5] * rescale p[,6] <- p[,6] * rescale # rename the columns names(p)[5:6] <- c("Std. Estimate", "Std.Std.Error") # bye! return(p) }semPlot/R/princomp.R0000644000176200001440000000102114267410262014046 0ustar liggesusers# semPaths.princomp <- function(object,...) # { # invisible(semPaths(semPlotModel(object),...)) # } # ### SINGLE GROUP MODEL ### semPlotModel.princomp <- function(object, ...) { # Check if object is of class "sem": if (!"princomp"%in%class(object)) stop("Input must be a 'princomp' object") # Extract model: mod <- semPlotModel(loadings(object)) manNames <- mod@Vars$name[mod@Vars$manifest] # Fix: mod@Pars[c("lhs","rhs")] <- mod@Pars[c("rhs","lhs")] mod@Pars$edge <- "->" return(mod) } semPlot/R/IntInNode.r0000644000176200001440000000537014267410262014121 0ustar liggesusersIntInNode <- function(layout,cex,shape,m,width=0.2,triangles=TRUE,col="black",side=1,inside=TRUE) { N <- nrow(layout) if (length(cex)==1) cex <- rep(cex,N) if (length(shape)==1) shape <- rep(shape,N) if (length(col)==1) col <- rep(col,N) if (length(side)==1) side <- rep(side,N) # m is vector of margins to plot lines, NA indicates no line # side: 1. bottom, 2. left, 3. top, 4. right. # inside: if TRUE thresholds are plotted in the node, filling from top to bottom, if FALSE they are plotted at the side. for (i in seq_along(m)) { if (!is.na(m[i])) { # browser() x <- layout[i,1] y <- layout[i,2] xran <- qgraph:::Cent2Edge(layout[i,1],layout[i,2],pi/2,cex[i],cex[i],shape[i])[1] - x yran <- qgraph:::Cent2Edge(layout[i,1],layout[i,2],0,cex[i],cex[i],shape[i])[2] - y if (!inside) { if (side[i]==1) { for (j in 1:length(m[[i]])) { lines(c(x-xran+m[[i]][j]*xran*2,x-xran+m[[i]][j]*xran*2),c(y-yran-width*yran,y-yran+width*yran),col=col[i]) } } else if (side[i]==2) { for (j in 1:length(m[[i]])) { lines(c(x-xran-width*xran,x-xran+width*xran),c(y-yran+m[[i]][j]*yran*2,y-yran+m[[i]][j]*yran*2),col=col[i]) } } else if (side[i]==3) { for (j in 1:length(m[[i]])) { lines(c(x-xran+m[[i]][j]*xran*2,x-xran+m[[i]][j]*xran*2),c(y+yran-width*yran,y+yran+width*yran),col=col[i]) } } else if (side[i]==4) { for (j in 1:length(m[[i]])) { lines(c(x+xran-width*xran,x+xran+width*xran),c(y-yran+m[[i]][j]*yran*2,y-yran+m[[i]][j]*yran*2),col=col[i]) } } } else { if (side[i]==1) { for (j in 1:length(m[[i]])) { lines(c(x-xran+m[[i]][j]*xran*2,x-xran+m[[i]][j]*xran*2),c(y-yran,y+yran),col=col[i]) } } else if (side[i]==2) { for (j in 1:length(m[[i]])) { lines(c(x-xran,x+xran),c(y-yran+m[[i]][j]*yran*2,y-yran+m[[i]][j]*yran*2),col=col[i]) } } else if (side[i]==3) { for (j in 1:length(m[[i]])) { lines(c(x-xran+m[[i]][j]*xran*2,x-xran+m[[i]][j]*xran*2),c(y-yran,y+yran),col=col[i]) } } else if (side[i]==4) { for (j in 1:length(m[[i]])) { lines(c(x-xran,x+xran),c(y-yran+m[[i]][j]*yran*2,y-yran+m[[i]][j]*yran*2),col=col[i]) } } } } } } # if (triangles) # { # points(x,y-yran+m[[i]][j]*yran*2,pch=17,cex=cex[1]/10,col=col[i]) # }semPlot/MD50000644000176200001440000000555214274657172012233 0ustar liggesusersff547ababc85108875b8e8f94239d4dd *COPYING 08ffa49d1511893a7b455a266788b23a *DESCRIPTION 8942c2bc60a9663af02cff22f9e8f408 *NAMESPACE 93877dd59e77aae9b118c2c69f14af30 *NEWS 6331dde1ac9c8dbbe8e76c99bee595f2 *R/00classes.R 579e8b2641f3e8a5178eba4a297314f1 *R/Imin.R 8c3648e41405f1aa7f68faffe5ba2efa *R/IntInNode.r 9248931db94f30f03d544b3deec71cbf *R/OpenMx.R 5b72ddd986870bd8e073676db942234a *R/Pars2Matrix.R b92da836d47ecc0b7f2b48815e406c19 *R/amos.R a12d237e8ab65edc2757040b398eccb4 *R/cvregsemplot.R 89ff726b3c2aa9772615acc067622404 *R/defExo.R a148129fc1a655b4f125a49358697e7b *R/editFuns.R 8f3707a6268747000876753d89cc25d9 *R/factanal.R f5fb2ffd916521a1f63d47490c7a03c7 *R/glm.R 5475c928a8b21487dfb7208eba80a749 *R/greplVarType.R f21b6d9493451ecdbe3b98974bc33bab *R/isColor.R 5fbdb0b3adedefab1386de1970ddccef *R/lavaan.R db340141043be8e68780902e1465ef10 *R/lavaanModel.R 5adb76ba7df5c50bdf532aacc49424be *R/lisrelMat2RAM.R 1221e8a125bb29366df794486075aa28 *R/lisrelModel.R 6c9247a19b360e63d9ab2f619e60ae57 *R/lists.R b067b152cf18742ea06c9cc0b4e2900c *R/loadings.R 7f1a3ef88b527ae5b1495e3fe8834813 *R/mappingfuns.R 4d17fa82fa3781ff1ca86fc3d1f4e18b *R/modelMatrices.R 79d6e5374d64dc7a6450693de1b96f5b *R/mplus.R 0e93679cadc5ac57360bbe1a36b1dbdf *R/onyx.R 69629ec92e90326d3aa630ac725cbb41 *R/operators.R 7622d921838cf952fbeaabe3caa5e894 *R/principal.R b05fdedba97ed0e1a86f91ab12565180 *R/princomp.R 641eff0ca6586f3773c38d15b5b4ac03 *R/ramModel.R 676e244f3f1fa6c1f5bd838b8c142916 *R/regsemplot.R 19b287a454a13bda0aaeef4094a41c4d *R/sem.R 2f61fd62584bf9c98bba51b97d80d3f4 *R/semCors.R 3b788e07050739e522904acf5c183363 *R/semMatrixAlgebra.R 54a416fe9b76c32e914eb46bb9c1ffc8 *R/semPaths.R 49c212fa8eac9efbc83b6db0ae8f4d8e *R/semPathsHelperFuns.R 0b144188f30172c797c5225f55e2a02b *R/semSyntax.R 685428c6eeee5aaca688f466d517c4f2 *R/semspec.R 112965b5673b518e97a64895c31236cd *R/semstandmsem.R eb883c696362d7353bd74cb606fa6e23 *R/standardizeRAM_2.R 974662a32f2c46f4f299663a9918b98a *R/zzz.R f9721ef43e5f912ddea844bafbf43ec5 *README 600343cabf23256660d9adc754f3f6e4 *inst/COPYRIGHTS fe8f33483833e151113dced7d32ca2ff *man/Imin.Rd 6485f1332059c3deb3601786ff6cafb3 *man/cvregsemplot.Rd dfd6670b4e9fc9fb2e63169fbcdf5783 *man/edits.Rd c55952e755b8121768815bb2634be5f1 *man/lisrelModel.Rd a9dfaff292a6e6693ca18ce268ba01f5 *man/modelMatrices.Rd b4a411cba4249567f3b7fb710eafab0c *man/ramModel.Rd 7dd339ada8549e1e46b52bfab2d69326 *man/regsemplot.Rd 5c6f88a5afd453c7a93137e70ecb8732 *man/semCors.Rd 3fe5f857fe776f01606b6241376f81e0 *man/semMatrixAlgebra.Rd 8250441336ec49046230eeb3b381ce73 *man/semPaths.Rd 7fcdabc526259cdaa114ff3b2fb9f6aa *man/semPlot-package.Rd e5996043cd0f0d7f8bc03b8dd621c366 *man/semPlotModel-class.Rd c4fced0a3e226caed2d7422da3483664 *man/semPlotModel.Rd 5a26e6059f4f9f0a488631d89df21a97 *man/semPlotModel.S4-methods.Rd 972d995bfba14824948070c71f0ef508 *man/semSyntax.Rd 98aebe08c8a4c48a6c36c81ec0b37f39 *man/tricks.Rd semPlot/inst/0000755000176200001440000000000014267410262012656 5ustar liggesuserssemPlot/inst/COPYRIGHTS0000644000176200001440000000040214267410262014270 0ustar liggesusersCOPYRIGHT STATUS ---------------- This code is Copyright (C) 2013, 2014, 2015, 2016, 2017 Sacha Epskamp All code is subject to the GNU General Public License, Version 2. See the file COPYING for the exact conditions under which you may redistribute it.