├── COPYING ├── DESCRIPTION ├── NAMESPACE ├── NEWS ├── R ├── 00classes.R ├── Imin.R ├── IntInNode.r ├── OpenMx.R ├── Pars2Matrix.R ├── amos.R ├── cvregsemplot.R ├── defExo.R ├── editFuns.R ├── factanal.R ├── glm.R ├── greplVarType.R ├── isColor.R ├── lavaan.R ├── lavaanModel.R ├── lisrelMat2RAM.R ├── lisrelModel.R ├── lists.R ├── loadings.R ├── mappingfuns.R ├── modelMatrices.R ├── mplus.R ├── onyx.R ├── operators.R ├── principal.R ├── princomp.R ├── ramModel.R ├── regsemplot.R ├── sem.R ├── semCors.R ├── semMatrixAlgebra.R ├── semPaths.R ├── semPathsHelperFuns.R ├── semSyntax.R ├── semspec.R ├── semstandmsem.R ├── standardizeRAM_2.R └── zzz.R ├── README ├── inst └── COPYRIGHTS └── man ├── Imin.Rd ├── cvregsemplot.Rd ├── edits.Rd ├── lisrelModel.Rd ├── modelMatrices.Rd ├── ramModel.Rd ├── regsemplot.Rd ├── semCors.Rd ├── semMatrixAlgebra.Rd ├── semPaths.Rd ├── semPlot-package.Rd ├── semPlotModel-class.Rd ├── semPlotModel.Rd ├── semPlotModel.S4-methods.Rd ├── semSyntax.Rd └── tricks.Rd /COPYING: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 2, June 1991 3 | 4 | Copyright (C) 1989, 1991 Free Software Foundation, Inc. 5 | 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 6 | Everyone is permitted to copy and distribute verbatim copies 7 | of this license document, but changing it is not allowed. 8 | 9 | Preamble 10 | 11 | The licenses for most software are designed to take away your 12 | freedom to share and change it. By contrast, the GNU General Public 13 | License is intended to guarantee your freedom to share and change free 14 | software--to make sure the software is free for all its users. This 15 | General Public License applies to most of the Free Software 16 | Foundation's software and to any other program whose authors commit to 17 | using it. (Some other Free Software Foundation software is covered by 18 | the GNU Library General Public License instead.) You can apply it to 19 | your programs, too. 20 | 21 | When we speak of free software, we are referring to freedom, not 22 | price. Our General Public Licenses are designed to make sure that you 23 | have the freedom to distribute copies of free software (and charge for 24 | this service if you wish), that you receive source code or can get it 25 | if you want it, that you can change the software or use pieces of it 26 | in new free programs; and that you know you can do these things. 27 | 28 | To protect your rights, we need to make restrictions that forbid 29 | anyone to deny you these rights or to ask you to surrender the rights. 30 | These restrictions translate to certain responsibilities for you if you 31 | distribute copies of the software, or if you modify it. 32 | 33 | For example, if you distribute copies of such a program, whether 34 | gratis or for a fee, you must give the recipients all the rights that 35 | you have. You must make sure that they, too, receive or can get the 36 | source code. And you must show them these terms so they know their 37 | rights. 38 | 39 | We protect your rights with two steps: (1) copyright the software, and 40 | (2) offer you this license which gives you legal permission to copy, 41 | distribute and/or modify the software. 42 | 43 | Also, for each author's protection and ours, we want to make certain 44 | that everyone understands that there is no warranty for this free 45 | software. If the software is modified by someone else and passed on, we 46 | want its recipients to know that what they have is not the original, so 47 | that any problems introduced by others will not reflect on the original 48 | authors' reputations. 49 | 50 | Finally, any free program is threatened constantly by software 51 | patents. We wish to avoid the danger that redistributors of a free 52 | program will individually obtain patent licenses, in effect making the 53 | program proprietary. To prevent this, we have made it clear that any 54 | patent must be licensed for everyone's free use or not licensed at all. 55 | 56 | The precise terms and conditions for copying, distribution and 57 | modification follow. 58 | 59 | GNU GENERAL PUBLIC LICENSE 60 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 61 | 62 | 0. This License applies to any program or other work which contains 63 | a notice placed by the copyright holder saying it may be distributed 64 | under the terms of this General Public License. The "Program", below, 65 | refers to any such program or work, and a "work based on the Program" 66 | means either the Program or any derivative work under copyright law: 67 | that is to say, a work containing the Program or a portion of it, 68 | either verbatim or with modifications and/or translated into another 69 | language. (Hereinafter, translation is included without limitation in 70 | the term "modification".) Each licensee is addressed as "you". 71 | 72 | Activities other than copying, distribution and modification are not 73 | covered by this License; they are outside its scope. The act of 74 | running the Program is not restricted, and the output from the Program 75 | is covered only if its contents constitute a work based on the 76 | Program (independent of having been made by running the Program). 77 | Whether that is true depends on what the Program does. 78 | 79 | 1. You may copy and distribute verbatim copies of the Program's 80 | source code as you receive it, in any medium, provided that you 81 | conspicuously and appropriately publish on each copy an appropriate 82 | copyright notice and disclaimer of warranty; keep intact all the 83 | notices that refer to this License and to the absence of any warranty; 84 | and give any other recipients of the Program a copy of this License 85 | along with the Program. 86 | 87 | You may charge a fee for the physical act of transferring a copy, and 88 | you may at your option offer warranty protection in exchange for a fee. 89 | 90 | 2. You may modify your copy or copies of the Program or any portion 91 | of it, thus forming a work based on the Program, and copy and 92 | distribute such modifications or work under the terms of Section 1 93 | above, provided that you also meet all of these conditions: 94 | 95 | a) You must cause the modified files to carry prominent notices 96 | stating that you changed the files and the date of any change. 97 | 98 | b) You must cause any work that you distribute or publish, that in 99 | whole or in part contains or is derived from the Program or any 100 | part thereof, to be licensed as a whole at no charge to all third 101 | parties under the terms of this License. 102 | 103 | c) If the modified program normally reads commands interactively 104 | when run, you must cause it, when started running for such 105 | interactive use in the most ordinary way, to print or display an 106 | announcement including an appropriate copyright notice and a 107 | notice that there is no warranty (or else, saying that you provide 108 | a warranty) and that users may redistribute the program under 109 | these conditions, and telling the user how to view a copy of this 110 | License. (Exception: if the Program itself is interactive but 111 | does not normally print such an announcement, your work based on 112 | the Program is not required to print an announcement.) 113 | 114 | These requirements apply to the modified work as a whole. If 115 | identifiable sections of that work are not derived from the Program, 116 | and can be reasonably considered independent and separate works in 117 | themselves, then this License, and its terms, do not apply to those 118 | sections when you distribute them as separate works. But when you 119 | distribute the same sections as part of a whole which is a work based 120 | on the Program, the distribution of the whole must be on the terms of 121 | this License, whose permissions for other licensees extend to the 122 | entire whole, and thus to each and every part regardless of who wrote it. 123 | 124 | Thus, it is not the intent of this section to claim rights or contest 125 | your rights to work written entirely by you; rather, the intent is to 126 | exercise the right to control the distribution of derivative or 127 | collective works based on the Program. 128 | 129 | In addition, mere aggregation of another work not based on the Program 130 | with the Program (or with a work based on the Program) on a volume of 131 | a storage or distribution medium does not bring the other work under 132 | the scope of this License. 133 | 134 | 3. You may copy and distribute the Program (or a work based on it, 135 | under Section 2) in object code or executable form under the terms of 136 | Sections 1 and 2 above provided that you also do one of the following: 137 | 138 | a) Accompany it with the complete corresponding machine-readable 139 | source code, which must be distributed under the terms of Sections 140 | 1 and 2 above on a medium customarily used for software interchange; or, 141 | 142 | b) Accompany it with a written offer, valid for at least three 143 | years, to give any third party, for a charge no more than your 144 | cost of physically performing source distribution, a complete 145 | machine-readable copy of the corresponding source code, to be 146 | distributed under the terms of Sections 1 and 2 above on a medium 147 | customarily used for software interchange; or, 148 | 149 | c) Accompany it with the information you received as to the offer 150 | to distribute corresponding source code. (This alternative is 151 | allowed only for noncommercial distribution and only if you 152 | received the program in object code or executable form with such 153 | an offer, in accord with Subsection b above.) 154 | 155 | The source code for a work means the preferred form of the work for 156 | making modifications to it. For an executable work, complete source 157 | code means all the source code for all modules it contains, plus any 158 | associated interface definition files, plus the scripts used to 159 | control compilation and installation of the executable. However, as a 160 | special exception, the source code distributed need not include 161 | anything that is normally distributed (in either source or binary 162 | form) with the major components (compiler, kernel, and so on) of the 163 | operating system on which the executable runs, unless that component 164 | itself accompanies the executable. 165 | 166 | If distribution of executable or object code is made by offering 167 | access to copy from a designated place, then offering equivalent 168 | access to copy the source code from the same place counts as 169 | distribution of the source code, even though third parties are not 170 | compelled to copy the source along with the object code. 171 | 172 | 4. You may not copy, modify, sublicense, or distribute the Program 173 | except as expressly provided under this License. Any attempt 174 | otherwise to copy, modify, sublicense or distribute the Program is 175 | void, and will automatically terminate your rights under this License. 176 | However, parties who have received copies, or rights, from you under 177 | this License will not have their licenses terminated so long as such 178 | parties remain in full compliance. 179 | 180 | 5. You are not required to accept this License, since you have not 181 | signed it. However, nothing else grants you permission to modify or 182 | distribute the Program or its derivative works. These actions are 183 | prohibited by law if you do not accept this License. Therefore, by 184 | modifying or distributing the Program (or any work based on the 185 | Program), you indicate your acceptance of this License to do so, and 186 | all its terms and conditions for copying, distributing or modifying 187 | the Program or works based on it. 188 | 189 | 6. Each time you redistribute the Program (or any work based on the 190 | Program), the recipient automatically receives a license from the 191 | original licensor to copy, distribute or modify the Program subject to 192 | these terms and conditions. You may not impose any further 193 | restrictions on the recipients' exercise of the rights granted herein. 194 | You are not responsible for enforcing compliance by third parties to 195 | this License. 196 | 197 | 7. If, as a consequence of a court judgment or allegation of patent 198 | infringement or for any other reason (not limited to patent issues), 199 | conditions are imposed on you (whether by court order, agreement or 200 | otherwise) that contradict the conditions of this License, they do not 201 | excuse you from the conditions of this License. If you cannot 202 | distribute so as to satisfy simultaneously your obligations under this 203 | License and any other pertinent obligations, then as a consequence you 204 | may not distribute the Program at all. For example, if a patent 205 | license would not permit royalty-free redistribution of the Program by 206 | all those who receive copies directly or indirectly through you, then 207 | the only way you could satisfy both it and this License would be to 208 | refrain entirely from distribution of the Program. 209 | 210 | If any portion of this section is held invalid or unenforceable under 211 | any particular circumstance, the balance of the section is intended to 212 | apply and the section as a whole is intended to apply in other 213 | circumstances. 214 | 215 | It is not the purpose of this section to induce you to infringe any 216 | patents or other property right claims or to contest validity of any 217 | such claims; this section has the sole purpose of protecting the 218 | integrity of the free software distribution system, which is 219 | implemented by public license practices. Many people have made 220 | generous contributions to the wide range of software distributed 221 | through that system in reliance on consistent application of that 222 | system; it is up to the author/donor to decide if he or she is willing 223 | to distribute software through any other system and a licensee cannot 224 | impose that choice. 225 | 226 | This section is intended to make thoroughly clear what is believed to 227 | be a consequence of the rest of this License. 228 | 229 | 8. If the distribution and/or use of the Program is restricted in 230 | certain countries either by patents or by copyrighted interfaces, the 231 | original copyright holder who places the Program under this License 232 | may add an explicit geographical distribution limitation excluding 233 | those countries, so that distribution is permitted only in or among 234 | countries not thus excluded. In such case, this License incorporates 235 | the limitation as if written in the body of this License. 236 | 237 | 9. The Free Software Foundation may publish revised and/or new versions 238 | of the General Public License from time to time. Such new versions will 239 | be similar in spirit to the present version, but may differ in detail to 240 | address new problems or concerns. 241 | 242 | Each version is given a distinguishing version number. If the Program 243 | specifies a version number of this License which applies to it and "any 244 | later version", you have the option of following the terms and conditions 245 | either of that version or of any later version published by the Free 246 | Software Foundation. If the Program does not specify a version number of 247 | this License, you may choose any version ever published by the Free Software 248 | Foundation. 249 | 250 | 10. If you wish to incorporate parts of the Program into other free 251 | programs whose distribution conditions are different, write to the author 252 | to ask for permission. For software which is copyrighted by the Free 253 | Software Foundation, write to the Free Software Foundation; we sometimes 254 | make exceptions for this. Our decision will be guided by the two goals 255 | of preserving the free status of all derivatives of our free software and 256 | of promoting the sharing and reuse of software generally. 257 | 258 | NO WARRANTY 259 | 260 | 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY 261 | FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN 262 | OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES 263 | PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED 264 | OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 265 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS 266 | TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE 267 | PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, 268 | REPAIR OR CORRECTION. 269 | 270 | 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 271 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR 272 | REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, 273 | INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING 274 | OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED 275 | TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY 276 | YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER 277 | PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE 278 | POSSIBILITY OF SUCH DAMAGES. 279 | 280 | END OF TERMS AND CONDITIONS 281 | 282 | How to Apply These Terms to Your New Programs 283 | 284 | If you develop a new program, and you want it to be of the greatest 285 | possible use to the public, the best way to achieve this is to make it 286 | free software which everyone can redistribute and change under these terms. 287 | 288 | To do so, attach the following notices to the program. It is safest 289 | to attach them to the start of each source file to most effectively 290 | convey the exclusion of warranty; and each file should have at least 291 | the "copyright" line and a pointer to where the full notice is found. 292 | 293 | 294 | Copyright (C) 295 | 296 | This program is free software; you can redistribute it and/or modify 297 | it under the terms of the GNU General Public License as published by 298 | the Free Software Foundation; either version 2 of the License, or 299 | (at your option) any later version. 300 | 301 | This program is distributed in the hope that it will be useful, 302 | but WITHOUT ANY WARRANTY; without even the implied warranty of 303 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 304 | GNU General Public License for more details. 305 | 306 | You should have received a copy of the GNU General Public License 307 | along with this program; if not, write to the Free Software 308 | Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 309 | 310 | 311 | Also add information on how to contact you by electronic and paper mail. 312 | 313 | If the program is interactive, make it output a short notice like this 314 | when it starts in an interactive mode: 315 | 316 | Gnomovision version 69, Copyright (C) year name of author 317 | Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 318 | This is free software, and you are welcome to redistribute it 319 | under certain conditions; type `show c' for details. 320 | 321 | The hypothetical commands `show w' and `show c' should show the appropriate 322 | parts of the General Public License. Of course, the commands you use may 323 | be called something other than `show w' and `show c'; they could even be 324 | mouse-clicks or menu items--whatever suits your program. 325 | 326 | You should also get your employer (if you work as a programmer) or your 327 | school, if any, to sign a "copyright disclaimer" for the program, if 328 | necessary. Here is a sample; alter the names: 329 | 330 | Yoyodyne, Inc., hereby disclaims all copyright interest in the program 331 | `Gnomovision' (which makes passes at compilers) written by James Hacker. 332 | 333 | , 1 April 1989 334 | Ty Coon, President of Vice 335 | 336 | This General Public License does not permit incorporating your program into 337 | proprietary programs. If your program is a subroutine library, you may 338 | consider it more useful to permit linking proprietary applications with the 339 | library. If this is what you want to do, use the GNU Library General 340 | Public License instead of this License. -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: semPlot 2 | Type: Package 3 | Title: Path Diagrams and Visual Analysis of Various SEM Packages' Output 4 | Version: 1.1.5 5 | Authors@R: c( 6 | person("Sacha", "Epskamp", email = "mail@sachaepskamp.com",role = c("aut", "cre")), 7 | person("Simon", "Stuber", role = c("ctb")), 8 | person("Jason", "Nak", role = c("ctb")), 9 | person("Myrthe", "Veenman", role = c("ctb")), 10 | person(given = c("Terrence","D."), family = "Jorgensen", role = c("ctb"), comment = c(ORCID = "0000-0001-5111-6773")) 11 | ) 12 | Maintainer: Sacha Epskamp 13 | Depends: R (>= 2.15.0) 14 | Suggests: MplusAutomation (>= 0.5-3) 15 | 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 16 | ByteCompile: yes 17 | Description: Path diagrams and visual analysis of various SEM packages' output. 18 | URL: https://github.com/SachaEpskamp/semPlot 19 | License: GPL-2 20 | LazyLoad: yes 21 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | export(semPaths,semPlotModel,semCors,lisrelModel,ramModel,semSyntax, 2 | semMatrixAlgebra,modelMatrices,Imin,semPlotModel_lavaanModel) 3 | 4 | # export Classes 5 | exportClasses( 6 | "semPlotModel" 7 | ) 8 | 9 | # export Methods 10 | exportMethods( 11 | "semPlotModel_S4" 12 | ) 13 | 14 | S3method("+",semPlotModel) 15 | S3method(semPlotModel,list) 16 | S3method(semPlotModel,lm) 17 | S3method(semPlotModel,principal) 18 | S3method(semPlotModel,princomp) 19 | S3method(semPlotModel,loadings) 20 | S3method(semPlotModel,lisrel) 21 | S3method(semPlotModel,factanal) 22 | S3method(semPlotModel,default) 23 | S3method(semPlotModel,mplus.model) 24 | S3method(semPlotModel,sem) 25 | S3method(semPlotModel,msem) 26 | S3method(semPlotModel,msemObjectiveML) 27 | export(semPlotModel_Onyx) 28 | export(semPlotModel_Amos) 29 | export(exo,"exo<-",endo,"endo<-",lat,"lat<-",man,"man<-") 30 | S3method(semPlotModel,regsem) 31 | S3method(semPlotModel,cvregsem) 32 | 33 | # importFrom(MplusAutomation,"readModels") 34 | importFrom(sem,"sem","standardizedCoefficients","specifyModel") 35 | importFrom(lavaan,"lavaan","cfa","standardizedSolution", "standardizedsolution", "parameterEstimates", "parameterestimates","inspect","lavaanNames","lavaanify","lavInspect","lavTech") 36 | importClassesFrom(lavaan,"lavaan") 37 | importFrom(stats,"factanal") 38 | importFrom(rockchalk,standardize) 39 | #importFrom(regsem, "regsem","cv_regsem") 40 | import(plyr) 41 | import(lisrelToR) 42 | import(XML) 43 | import(qgraph) 44 | import(methods) 45 | import(OpenMx) 46 | #import(semTools) 47 | importFrom(igraph,"layout.reingold.tilford","graph.edgelist","shortest.paths") 48 | importFrom(colorspace,rainbow_hcl) 49 | importFrom(corpcor,"pseudoinverse") 50 | importFrom("grDevices", "col2rgb", "rainbow", "rgb") 51 | importFrom("graphics", "lines", "par", "text") 52 | importFrom("stats", "ave", "coef", "cov", "cov2cor", "loadings", 53 | "median", "pnorm", "weighted.mean") 54 | importFrom("utils", "packageDescription") 55 | 56 | -------------------------------------------------------------------------------- /NEWS: -------------------------------------------------------------------------------- 1 | Changes in Version 1.1.5 2 | o Small change to a link used in an example 3 | 4 | Changes in Version 1.1.4 5 | o Fixed issues with new lavaan version 6 | o Small fix for CRAN 7 | 8 | Changes in Version 1.1.3 9 | o the 'ramModel' function now supports meanstructure with the 'M' argument. 10 | o Fixed an issue with lavaan 11 | 12 | Changes in Version 1.1.1 13 | o regsem and cv_regsem support added, thanks to Myrthe Veenman and Jason Nak! 14 | 15 | Changes in Version 1.1 16 | o Fixed a bug with lavaan input 17 | o Fixed a bug with OpenMx 2 input 18 | o The 'mplusStd' argument of semPlotModel can now be used to specify standardization of mplus models 19 | o Fixed a bug related to model constraints 20 | o Several updates to accomidate new CRAN checks 21 | 22 | Changes in Version 1.0.1 23 | o Fixed a dependency related bug causing examples to crash. 24 | 25 | Changes in Version 1.0.0 26 | 27 | New features: 28 | o Added the argument 'curveAdjacent' to also curve the covariances between two adjacent nodes as curved edges. 29 | 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. 30 | 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. 31 | o Added the 'equalizeManifests' argument to equalize the spacing between manifest variables in the 'tree1' layout. 32 | o Added the 'covAtResiduals' argument that controls if covariances should be linked to residuals rather than nodes themselves if style="lisrel" 33 | o Added the 'bifactor' argument to create bifactor layouts. Only supported with layouts 'tree2', 'tree3', 'circle2' and 'circle3'. 34 | o optimizeLatRes has been improved 35 | o Added 'optimizePoints' arguments that can be given a vector of radians residuals can optimize to if optimizeLatRes = TRUE. 36 | 37 | Changes: 38 | o The argument curvePivot now defaults to FALSE, causing covariances by default to once again be drawn by circular curved edges. 39 | o A list of usefull qgraph arguments that can be used in semPaths is now listed in the semPaths help page. 40 | o 'mixCols' renamed to 'inheritColor' 41 | o The color argument can now be assined a list for assignng specific colors to all manifests, latents or intercepts 42 | o Some improvements to 'semCors' 43 | 44 | 45 | Bug fixes: 46 | o Fixed a bug where using style='lisrel' did not correctly curve covariances between latents. 47 | 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. 48 | 49 | 50 | Changes in Version 0.3.3 51 | o Lavaan model syntax is now supported as input 52 | o Numeric edge labels without using whatLabels argument are now correctly abbreviated 53 | o Several small fixes 54 | 55 | Changes in Version 0.3.2 56 | o New features 57 | o Matrix model functionality: 58 | o Added 'semMatrixAlgebra' to easily perform matrix algebra on any semPlot input object. 59 | o Added 'modelMatrices' to obtain model matrices of LISREL, Mplus and RAM modeling frameworks of any input to semPlot. 60 | o Added 'exoVar' and 'exoCov' arguments that can be used to not display variances or covariances of truly exogenous variables (no incoming directed edges) 61 | 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. 62 | 63 | o Major changes 64 | 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. 65 | 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. 66 | o 'style' now defaults to "lisrel" if the input is a Lisrel model. 67 | o 'style="lisrel"' will now default exoVar to FALSE. 68 | o Changed the name of slot RAM to Pars in semPlotModel class. 69 | o Two-level multilevel structures is now supported 70 | o Currently this works for Mplus input only. 71 | o Only random intercepts are supported, not random slopes. 72 | o Thresholds are shown on the within level rather than the between level. 73 | 74 | o New arguments to semPaths: 75 | o Added argument thresholdSize to control the size of threshold bars 76 | o Added 'levels' argument. This argument can be used to control the spacing between levels (e.g., exogenous latents) of tree and circle layouts. 77 | o Added nDigits argument to control the number of digits used in rounding for labels. 78 | o Added 'centerLevels' argument for tree2 layout, to center horizontal levels. 79 | o Added 'panelGroups' argument to automatically create a panel plot of multiple group models. 80 | 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. 81 | 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'. 82 | o Added 'nDigits' argument to control rounding of numeric values. 83 | 84 | o Minor changes 85 | o Thresholds are now plotted via qgraph 86 | o Changed argument threshold.color to thresholdColor 87 | o 'qgraph' is no longer on the depends list but imported instead. 88 | o 'as.expression' now defaults to "edges" if the input is a lisrel model. 89 | o 'semPlotModel' for lisrel modes can now use dots to send arguments to 'lisrelModel' 90 | o Added 'reduce' argument to lisrelModel that controls if variables that are named the same should be treated as the same variable. 91 | o Shape, width and height of manifest, latent and constant variables can now be set. 92 | o Mplus input now supports the | operator. 93 | 94 | o Bug fixes 95 | o Fixed a bug where numeric labels where abbreviated, causing erratic behavior on the labels. 96 | o Fixed a bug where models with single indicator latent variables caused an error. 97 | o Numerous small bugfixes and improvements 98 | o Fixed a bug where variable names in mplux models containing BY, WITH or ON caused unexpected behavior. 99 | o Assigning a matrix to the layout argument of semPaths will no longer cause a bunch or warnings. 100 | 101 | 102 | Changes in Version 0.3 103 | o First submit to CRAN. 104 | -------------------------------------------------------------------------------- /R/00classes.R: -------------------------------------------------------------------------------- 1 | ## SemPlotModel 2 | # Note on edge specification: 3 | # '->' is factor loading 4 | # '~>' is regression 5 | # '<->' is (co)variance 6 | # 'int' is an intercept 7 | 8 | setClass( "semPlotModel", representation( 9 | Pars = "data.frame", 10 | Vars = "data.frame", 11 | Thresholds = "data.frame", 12 | Computed = "logical", 13 | ObsCovs = "list", 14 | ImpCovs = "list", 15 | Original = "list")) 16 | 17 | setGeneric("semPlotModel_S4", function(object,...) { 18 | standardGeneric("semPlotModel_S4") 19 | }) 20 | # 21 | # setGeneric("semPaths.S4", function(object,...) { 22 | # standardGeneric("semPaths.S4") 23 | # }) 24 | # 25 | # semPaths <- function(object,...) 26 | # { 27 | # if ("MxRAMModel"%in%class(object)) return(semPaths_MxRAMModel(object,...)) 28 | # if ("MxModel"%in%class(object)) return(semPaths_MxModel(object,...)) 29 | # if(isS4(object)) 30 | # { 31 | # semPaths.S4(object, ...) 32 | # } else 33 | # { 34 | # UseMethod("semPaths", object) 35 | # } 36 | # } 37 | 38 | semPlotModel <- function (object, ...) { 39 | # Check if call contains a + operator, if so combine models: 40 | 41 | call <- paste(deparse(substitute(object)), collapse = "") 42 | if (grepl("\\+",call) & !grepl("\"",call) & !grepl("\'",call)) 43 | { 44 | args <- unlist(strsplit(call,split="\\+")) 45 | obs <- lapply(args,function(x)semPlotModel(eval(parse(text=x)))) 46 | Res <- obs[[1]] 47 | for (i in 2:length(obs)) Res <- Res + obs[[i]] 48 | return(Res) 49 | } 50 | 51 | if ("MxRAMModel"%in%class(object)) return(semPlotModel_MxRAMModel(object)) 52 | if ("MxModel"%in%class(object)) return(semPlotModel_MxModel(object)) 53 | if(isS4(object)) 54 | { 55 | semPlotModel_S4(object) 56 | } else 57 | { 58 | UseMethod("semPlotModel", object) 59 | } 60 | } 61 | 62 | semPlotModel.semPlotModel <- function(object,...) object 63 | 64 | 65 | # semPaths.default <- function(object,...) 66 | # { 67 | # if (is.character(object) && grepl("\\.out",object)) 68 | # { 69 | # return(semPaths(readModels(object),...)) 70 | # } 71 | # } 72 | 73 | semPlotModel.default <- function(object,...) 74 | { 75 | if (is(object,'data.frame')) 76 | { 77 | mod <- try(semPlotModel_lavaanModel(object,...),silent=TRUE) 78 | if (!"try-error"%in%class(mod)) return(mod) 79 | } 80 | 81 | if (is.character(object)) 82 | { 83 | if (!file.exists(object)) 84 | { 85 | mod <- try(semPlotModel_lavaanModel(object,...),silent=TRUE) 86 | if (!"try-error"%in%class(mod)) return(mod) else stop("Input string neither an existing file or Lavaan model.") 87 | } 88 | # Find file: 89 | if (grepl("\\.xml",object,ignore.case=TRUE)) 90 | { 91 | return(semPlotModel_Onyx(object)) 92 | } 93 | if (grepl("\\.AmosOutput",object,ignore.case=TRUE)) 94 | { 95 | return(semPlotModel_Amos(object)) 96 | } 97 | 98 | # Read first 100 lines: 99 | head <- readLines(object, 10) 100 | if (any(grepl("mplus",head,ignore.case=TRUE))) 101 | { 102 | return(semPlotModel.mplus.model(object,...)) 103 | } 104 | 105 | if (any(grepl("l\\s*i\\s*s\\s*r\\s*e\\s*l",head,ignore.case=TRUE))) 106 | { 107 | return(semPlotModel(readLisrel(object))) 108 | } 109 | 110 | # If all else fais, just try everything and assume you get errors 111 | # if it is wrong: 112 | mod <- try(semPlotModel_lavaanModel(object,...),silent=TRUE) 113 | if (!"try-error"%in%class(mod)) return(mod) 114 | 115 | mod <- try(semPlotModel.mplus.model(object,...),silent=TRUE) 116 | if (!"try-error"%in%class(mod)) return(mod) 117 | 118 | mod <- try(semPlotModel(readLisrel(object)),silent=TRUE) 119 | if (!"try-error"%in%class(mod)) return(mod) 120 | 121 | mod <- try(semPlotModel_Onyx(object),silent=TRUE) 122 | if (!"try-error"%in%class(mod)) return(mod) 123 | 124 | mod <- try(semPlotModel_Amos(object),silent=TRUE) 125 | if (!"try-error"%in%class(mod)) return(mod) 126 | 127 | # Well, we failed... 128 | } 129 | 130 | stop("Object not recognized as SEM model") 131 | } 132 | -------------------------------------------------------------------------------- /R/Imin.R: -------------------------------------------------------------------------------- 1 | Imin <- function(x,inverse=FALSE) 2 | { 3 | if (any(dim(x)==0)) 4 | { 5 | return(array(0,dim=dim(x))) 6 | } else { 7 | x <- diag(1,nrow(x),ncol(x)) - x 8 | if (inverse) 9 | { 10 | res <- tryCatch(solve(x), error = function(e) FALSE, silent = TRUE) 11 | if (is.matrix(res)) return(res) else 12 | { 13 | res <- tryCatch(pseudoinverse(x), error = function(e) FALSE, silent = TRUE) 14 | if (is.matrix(res)) 15 | { 16 | warning("Psuedoinverse used for singular matrix. Standardized solution might not be proper.") 17 | return(res) 18 | } else 19 | { 20 | warning("Uninvertable matrix found and psuedoinverse could not be computed. Standardized solutions probably not proper.") 21 | return(array(0, dim=dim(x))) 22 | } 23 | } 24 | } else { 25 | res <- x 26 | } 27 | if (is.matrix(res)) return(res) else 28 | { 29 | warning("Uninvertable matrix found. Standardized solutions are not proper.") 30 | return(array(0, dim=dim(x))) 31 | } 32 | } 33 | } 34 | -------------------------------------------------------------------------------- /R/IntInNode.r: -------------------------------------------------------------------------------- 1 | IntInNode <- function(layout,cex,shape,m,width=0.2,triangles=TRUE,col="black",side=1,inside=TRUE) 2 | { 3 | N <- nrow(layout) 4 | if (length(cex)==1) cex <- rep(cex,N) 5 | if (length(shape)==1) shape <- rep(shape,N) 6 | if (length(col)==1) col <- rep(col,N) 7 | if (length(side)==1) side <- rep(side,N) 8 | 9 | # m is vector of margins to plot lines, NA indicates no line 10 | # side: 1. bottom, 2. left, 3. top, 4. right. 11 | # inside: if TRUE thresholds are plotted in the node, filling from top to bottom, if FALSE they are plotted at the side. 12 | 13 | for (i in seq_along(m)) 14 | { 15 | if (!is.na(m[i])) 16 | { 17 | # browser() 18 | x <- layout[i,1] 19 | y <- layout[i,2] 20 | xran <- qgraph:::Cent2Edge(layout[i,1],layout[i,2],pi/2,cex[i],cex[i],shape[i])[1] - x 21 | yran <- qgraph:::Cent2Edge(layout[i,1],layout[i,2],0,cex[i],cex[i],shape[i])[2] - y 22 | 23 | if (!inside) 24 | { 25 | if (side[i]==1) 26 | { 27 | for (j in 1:length(m[[i]])) 28 | { 29 | 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]) 30 | } 31 | } else if (side[i]==2) 32 | { 33 | for (j in 1:length(m[[i]])) 34 | { 35 | 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]) 36 | } 37 | } else if (side[i]==3) 38 | { 39 | for (j in 1:length(m[[i]])) 40 | { 41 | 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]) 42 | } 43 | } else if (side[i]==4) 44 | { 45 | for (j in 1:length(m[[i]])) 46 | { 47 | 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]) 48 | } 49 | } 50 | } else 51 | { 52 | if (side[i]==1) 53 | { 54 | for (j in 1:length(m[[i]])) 55 | { 56 | lines(c(x-xran+m[[i]][j]*xran*2,x-xran+m[[i]][j]*xran*2),c(y-yran,y+yran),col=col[i]) 57 | } 58 | } else if (side[i]==2) 59 | { 60 | for (j in 1:length(m[[i]])) 61 | { 62 | lines(c(x-xran,x+xran),c(y-yran+m[[i]][j]*yran*2,y-yran+m[[i]][j]*yran*2),col=col[i]) 63 | } 64 | } else if (side[i]==3) 65 | { 66 | for (j in 1:length(m[[i]])) 67 | { 68 | lines(c(x-xran+m[[i]][j]*xran*2,x-xran+m[[i]][j]*xran*2),c(y-yran,y+yran),col=col[i]) 69 | } 70 | } else if (side[i]==4) 71 | { 72 | for (j in 1:length(m[[i]])) 73 | { 74 | lines(c(x-xran,x+xran),c(y-yran+m[[i]][j]*yran*2,y-yran+m[[i]][j]*yran*2),col=col[i]) 75 | } 76 | } 77 | } 78 | } 79 | } 80 | } 81 | # if (triangles) 82 | # { 83 | # points(x,y-yran+m[[i]][j]*yran*2,pch=17,cex=cex[1]/10,col=col[i]) 84 | # } -------------------------------------------------------------------------------- /R/OpenMx.R: -------------------------------------------------------------------------------- 1 | ### Path diagrams ### 2 | # 3 | # semPaths_MxRAMModel <- function(object,...){ 4 | # invisible(semPaths(semPlotModel(object),...)) 5 | # } 6 | # 7 | # semPaths_MxModel <- function(object,...){ 8 | # invisible(semPaths(semPlotModel(object),...)) 9 | # } 10 | # 11 | ### EXTRACT MODEL ### 12 | 13 | ### SINGLE GROUP ### 14 | semPlotModel_MxRAMModel <- function(object){ 15 | 16 | # Extract names: 17 | varNames <- object@manifestVars 18 | factNames <- object@latentVars 19 | if (!(length(varNames) || length(factNames))) 20 | stop(as.character(substitute(object)), '@manifestVars (and ', 21 | as.character(substitute(object)), '@latentVars if the model has ', 22 | 'latent variables) must contain variable names. You can set them ', 23 | 'using the manifestVars= and latentVars= arguments in mxModel().') 24 | 25 | # Standardized object: 26 | std <- OpenMx::mxStandardizeRAMpaths(object, SE = TRUE) 27 | 28 | # Extract directed paths: 29 | # Dirpaths <- which(t(object@matrices$A@free | object@matrices$A@values!=0),arr.ind=TRUE) 30 | # DirpathsFixed <- !t(object@matrices$A@free)[Dirpaths] 31 | # DirpathsValues <- t(object@matrices$A@values)[Dirpaths] 32 | # DirpathsLabels <- t(object@matrices$A@labels)[Dirpaths] 33 | 34 | # Extract symmetric paths: 35 | # Sympaths <- which(t(object@matrices$S@free | object@matrices$S@values!=0) & upper.tri(object@matrices$S@values,diag=TRUE),arr.ind=TRUE) 36 | # SympathsFixed <- !t(object@matrices$S@free)[Sympaths] 37 | # SympathsValues <- t(object@matrices$S@values)[Sympaths] 38 | # SympathsLabels <- t(object@matrices$A@labels)[Sympaths] 39 | 40 | # if (!is.null(object@matrices$M)) 41 | # { 42 | # # Extract intercepts: 43 | # Means <- which(object@matrices$M@free | object@matrices$M@values!=0) 44 | # MeansFixed <- !object@matrices$M@free[Means] 45 | # MeansValues <- object@matrices$M@values[Means] 46 | # MeansLabels <- object@matrices$M@labels[Means] 47 | # } else 48 | # { 49 | # Means <- numeric(0) 50 | # MeansFixed <- logical(0) 51 | # MeansValues <- numeric(0) 52 | # MeansLabels <- character(0) 53 | # } 54 | # 55 | # ## Standardized 56 | # if (!length(object@output)==0) 57 | # { 58 | # # browser() 59 | # # Function by Ryne Estabrook (http://openmx.psyc.virginia.edu/thread/718) 60 | # 61 | # standObj <- standardizeRAM(object,"model") 62 | # 63 | # # Extract directed paths: 64 | # # DirpathsValuesStd <- t(standObj@matrices$A@values)[Dirpaths] 65 | # # DirpathsValuesStd <- std$Std.Value[std$matrix=="A"] 66 | # 67 | # # Extract symmetric paths: 68 | # SympathsValuesStd <- t(standObj@matrices$S@values)[Sympaths] 69 | # 70 | # # Extract means: 71 | # 72 | #if (!is.null(standObj@matrices$M)) 73 | # { 74 | # MeansValuesStd <- standObj@matrices$S@values[Means] 75 | # } else { 76 | # MeansValuesStd <- numeric(0) 77 | # } 78 | # } else 79 | # { 80 | # DirpathsValuesStd <- rep(NA,nrow(Dirpaths)) 81 | # SympathsValuesStd <- rep(NA,nrow(Sympaths)) 82 | # MeansValuesStd <- rep(NA,length(Means)) 83 | # } 84 | # 85 | # Vars dataframe: 86 | Vars <- data.frame( 87 | name = c(varNames,factNames), 88 | manifest = c(varNames,factNames)%in%varNames, 89 | exogenous = NA, 90 | stringsAsFactors=FALSE) 91 | 92 | 93 | 94 | 95 | # standObj <- standardizeMx(object,free=T) # old semTools function, now in this file 96 | 97 | Edges <- std 98 | 99 | # Only edges in mats A and S: 100 | corMats <- Edges$matrix %in% c("A","S") 101 | 102 | # Define Pars: 103 | Pars <- data.frame( 104 | label = ifelse(is.na(Edges$label[corMats]),"",Edges$label[corMats]), 105 | lhs = Edges$col[corMats], 106 | edge = ifelse(Edges$matrix[corMats]=="A","->","<->"), 107 | rhs = Edges$row[corMats], 108 | est = Edges$Raw.Value[corMats], 109 | std = Edges$Std.Value[corMats], 110 | group = '', 111 | fixed = Edges$Raw.SE[corMats]==0, 112 | par = 0, 113 | stringsAsFactors=FALSE) 114 | 115 | 116 | 117 | # Maybe remove ints? 118 | if (!is.null(object@matrices$M)) { 119 | MeanStd <- c(object@matrices$M$values) 120 | 121 | ## in case labels are NA, use variable names 122 | if (!is.null(colnames(object@matrices$M$values))) { 123 | v.names <- colnames(object@matrices$M$values) 124 | v.idx <- v.names 125 | names(MeanStd) <- v.names 126 | } else { 127 | #FIXME? Warn users that this assumes order is {all manifest, all latent} 128 | v.names <- c(varNames, factNames) 129 | v.idx <- seq_along(v.names) 130 | } 131 | ## extract rows of std corresponding to the M matrix 132 | stdM <- std[std$matrix == "M", , drop = FALSE] 133 | ## loop over variable names that have a standardized estimate 134 | ## (only free parameters; assume others are fixed to zero) 135 | for (v in seq_along(stdM$col)) { 136 | MeanStd[ v.idx[v] ] <- stdM$Std.Value[stdM$col == v.idx[v] ] 137 | } 138 | ## old method (using deprecated semTools function, now at the bottom of this script) 139 | ## standardizeMx(object,free=T)[which(names(standardizeMx(object,free=T))%in%object@matrices$M$labels)] 140 | 141 | MeanEst <-data.frame( 142 | label = c(object@matrices$M$labels), 143 | ##### or, if they are NA, replace with variable names? 144 | # label = ifelse(!is.na(object@matrices$M$labels), 145 | # yes = object@matrices$M$labels, 146 | # no = v.names), 147 | lhs = '', 148 | rhs = v.names, 149 | edge = 'int', 150 | est = c(object@matrices$M$values), 151 | std = MeanStd, 152 | group = '', 153 | fixed = c(!object@matrices$M$free), 154 | par = 0, 155 | stringsAsFactors = FALSE ) 156 | Pars <- rbind(Pars,MeanEst) 157 | } 158 | 159 | 160 | 161 | 162 | Pars$par[is.na(Pars$label)] <- seq_len(sum(is.na(Pars$label))) 163 | for (lbl in unique(Pars$label[!is.na(Pars$label)])) 164 | { 165 | Pars$par[Pars$label==lbl] <- max(Pars$par)+1 166 | } 167 | # 168 | # # Add standardized: 169 | # for (i in 1:nrow(standPars)) 170 | # { 171 | # if (standPars$matrix[i] == "A") 172 | # { 173 | # Pars$std[Pars$lhs == standPars$col[i] & Pars$rhs == standPars$row[i] & Pars$edge == "->"] <- standPars[["Std. Estimate"]][i] 174 | # } 175 | # if (standPars$matrix[i] == "S") 176 | # { 177 | # Pars$std[Pars$lhs == standPars$col[i] & Pars$rhs == standPars$row[i] & Pars$edge == "<->"] <- standPars[["Std. Estimate"]][i] 178 | # } 179 | # } 180 | 181 | Pars$label[is.na(Pars$label)] <- "" 182 | 183 | semModel <- new("semPlotModel") 184 | semModel@Pars <- Pars 185 | semModel@Vars <- Vars 186 | semModel@Computed <- !length(object@output)==0 187 | semModel@Original <- list(object) 188 | 189 | if (!is.null(object@data)) 190 | { 191 | if (object@data@type=="cov") 192 | { 193 | semModel@ObsCovs <- list(object@data@observed) 194 | } else if (object@data@type=="raw") 195 | { 196 | semModel@ObsCovs <- list(cov(object@data@observed)) 197 | } else 198 | { 199 | semModel@ObsCovs <- list(NULL) 200 | } 201 | } else 202 | { 203 | semModel@ObsCovs <- list(NULL) 204 | } 205 | 206 | 207 | semModel@ImpCovs <- list(object@fitfunction@info$expCov) 208 | 209 | return(semModel) 210 | } 211 | 212 | 213 | semPlotModel_MxModel <- function(object){ 214 | 215 | if (any(!"MxRAMModel"%in%sapply(object@submodels,class))) stop("Model or all submodels must be of class 'MxRAMModel'") 216 | for (i in 1:length(object@submodels)) object@submodels[[i]]@output <- list(TRUE) 217 | S4objects <- lapply(object@submodels,semPlotModel) 218 | 219 | semModel <- new("semPlotModel") 220 | semModel@Pars <- do.call("rbind",lapply(S4objects,slot,"Pars")) 221 | 222 | semModel@Pars$par <- 0 223 | semModel@Pars$par[semModel@Pars$label==""] <- seq_len(sum(semModel@Pars$label=="")) 224 | for (lbl in unique(semModel@Pars$label[semModel@Pars$label!=""])) 225 | { 226 | semModel@Pars$par[semModel@Pars$label==lbl] <- max(semModel@Pars$par)+1 227 | } 228 | 229 | semModel@Vars <- S4objects[[1]]@Vars 230 | semModel@Computed <- !length(object@output)==0 231 | semModel@Original <- list(object) 232 | 233 | semModel@ObsCovs <- lapply(S4objects,function(x)x@ObsCovs[[1]]) 234 | names(semModel@ObsCovs) <- sapply(object@submodels,slot,"name") 235 | 236 | 237 | semModel@ImpCovs <- lapply(S4objects,function(x)x@ImpCovs[[1]]) 238 | names(semModel@ImpCovs) <- sapply(object@submodels,slot,"name") 239 | 240 | 241 | return(semModel) 242 | } 243 | 244 | 245 | 246 | 247 | 248 | ## ----------------------------------------------------------------- 249 | ## semTools function (no longer used, but can be borrowed if needed) 250 | ## ----------------------------------------------------------------- 251 | 252 | standardizeMx <- function(object, free = TRUE) { 253 | .Deprecated(msg = c("The standardizeMx function is deprecated, and it will", 254 | " cease to be included in future versions of semTools.", 255 | " See help('semTools-deprecated) for details.")) 256 | # objectOrig <- object 257 | multigroup <- length(object@submodels) > 0 258 | if(multigroup) { 259 | defVars <- lapply(object@submodels, findDefVars) 260 | defVars <- do.call(c, defVars) 261 | } else { 262 | defVars <- findDefVars(object) 263 | } 264 | if(length(defVars) > 0) stop("The standardizeMx is not available for the model with definition variable.") 265 | if(multigroup) { 266 | object@submodels <- lapply(object@submodels, standardizeMxSingleGroup) 267 | } else { 268 | object <- standardizeMxSingleGroup(object) 269 | } 270 | vectorizeMx(object, free=free) 271 | } 272 | 273 | ## Hidden functions 274 | 275 | findDefVars <- function(object) { 276 | ## borrowed from OpenMx::imxIsDefinitionVariable 277 | imxSeparatorChar <- "." 278 | imxIsDefinitionVariable <- function (name) { 279 | if (is.na(name)) { 280 | return(FALSE) 281 | } 282 | components <- unlist(strsplit(name, imxSeparatorChar, fixed = TRUE)) 283 | if (length(components) == 2 && components[[1]] == "data") { 284 | return(TRUE) 285 | } 286 | else if (length(components) > 2 && components[[2]] == "data") { 287 | return(TRUE) 288 | } 289 | else { 290 | return(FALSE) 291 | } 292 | } 293 | ## end borrowed code 294 | mat <- lapply(object@matrices, slot, "labels") 295 | defvars <- sapply(mat, function(x) x[apply(x, c(1,2), imxIsDefinitionVariable)]) 296 | Reduce("c", defvars) 297 | } 298 | 299 | vectorizeMx <- function(object, free = TRUE) { 300 | multigroup <- length(object@submodels) > 0 301 | if(multigroup) { 302 | object <- object@submodels 303 | } else { 304 | object <- list(object) 305 | } 306 | result <- NULL 307 | for(i in seq_along(object)) { 308 | name <- "" 309 | if(multigroup) name <- paste0(object[[i]]@name, ".") 310 | mat <- object[[i]]@matrices 311 | for(j in seq_along(mat)) { 312 | tempname <- paste0(name, mat[[j]]@name) 313 | lab <- mat[[j]]@labels 314 | tempfree <- as.vector(mat[[j]]@free) 315 | madeLab <- paste0(tempname, "[", row(lab), ",", col(lab), "]") 316 | lab <- as.vector(lab) 317 | madeLab[!is.na(lab)] <- lab[!is.na(lab)] 318 | if(!free) tempfree <- rep(TRUE, length(tempfree)) 319 | temp <- mat[[j]]@values[tempfree] 320 | names(temp) <- madeLab[tempfree] 321 | result <- c(result, temp) 322 | } 323 | } 324 | 325 | result[!duplicated(names(result))] 326 | } 327 | 328 | standardizeMxSingleGroup <- function(object) { 329 | if (!is(object@expectation, "MxExpectationRAM")) 330 | stop("The standardizeMx function is available for the MxExpectationRAM only.") 331 | A <- object@matrices$A@values 332 | I <- diag(nrow(A)) 333 | S <- object@matrices$S@values 334 | # F <- object@matrices$F@values 335 | Z <- solve(I - A) 336 | impliedCov <- Z %*% S %*% t(Z) 337 | temp <- sqrt(diag(impliedCov)) 338 | if (length(temp) == 1) { 339 | ImpliedSd <- as.matrix(temp) 340 | } else { 341 | ImpliedSd <- diag(temp) 342 | } 343 | ImpliedInvSd <- solve(ImpliedSd) 344 | object@matrices$S@values <- ImpliedInvSd %*% S %*% ImpliedInvSd 345 | object@matrices$A@values <- ImpliedInvSd %*% A %*% ImpliedSd 346 | if (!is.null(object@matrices$M)) { 347 | M <- object@matrices$M@values 348 | object@matrices$M@values <- M %*% ImpliedInvSd 349 | } 350 | object 351 | } 352 | 353 | 354 | 355 | -------------------------------------------------------------------------------- /R/Pars2Matrix.R: -------------------------------------------------------------------------------- 1 | # Inner function, computes matrix from Pars subsection: 2 | # Pars: Sub of Pars 3 | # rows: Rownames 4 | # cols: Colnames 5 | # lhsisrow: lhs variable is interpreted as row (default to FALSE) 6 | Pars2Matrix <- function(Pars, edges, rows, cols, symmetrical, lhsisrow = FALSE) 7 | { 8 | if (missing(symmetrical)) 9 | { 10 | symmetrical <- any(grepl("<->",edges)) 11 | } 12 | if (lhsisrow) Pars[c('lhs','rhs')] <- Pars[c('rhs','lhs')] 13 | Groups <- unique(Pars$group) 14 | Pars$lhs[Pars$edge=="int"] <- "1" 15 | 16 | Pars <- Pars[Pars$edge %in% edges & Pars$lhs %in% cols & Pars$rhs %in% rows,] 17 | 18 | ResMatrix <- list() 19 | empMatrix <- matrix(0, length(rows), length(cols)) 20 | rownames(empMatrix) <- gsub("@L@","",rows) 21 | colnames(empMatrix) <- gsub("@L@","",cols) 22 | for (i in seq_along(Groups)) 23 | { 24 | GroupPars <- Pars[Pars$group == Groups[i],] 25 | ResMatrix[[i]] <- list() 26 | ResMatrix[[i]]$est <- empMatrix 27 | ResMatrix[[i]]$std <- empMatrix 28 | ResMatrix[[i]]$par <- empMatrix 29 | ResMatrix[[i]]$fixed <- empMatrix 30 | mode(ResMatrix[[i]]$fixed) <- "logical" 31 | for (j in seq_len(nrow(GroupPars))) 32 | { 33 | ResMatrix[[i]]$est[match(GroupPars$rhs[j],rows),match(GroupPars$lhs[j],cols)] <- GroupPars$est[j] 34 | ResMatrix[[i]]$std[match(GroupPars$rhs[j],rows),match(GroupPars$lhs[j],cols)] <- GroupPars$std[j] 35 | ResMatrix[[i]]$fixed[match(GroupPars$rhs[j],rows),match(GroupPars$lhs[j],cols)] <- GroupPars$fixed[j] 36 | ResMatrix[[i]]$par[match(GroupPars$rhs[j],rows),match(GroupPars$lhs[j],cols)] <- GroupPars$par[j] 37 | if (symmetrical) 38 | { 39 | ResMatrix[[i]]$est[match(GroupPars$lhs[j],rows),match(GroupPars$rhs[j],cols)] <- GroupPars$est[j] 40 | ResMatrix[[i]]$std[match(GroupPars$lhs[j],rows),match(GroupPars$rhs[j],cols)] <- GroupPars$std[j] 41 | ResMatrix[[i]]$fixed[match(GroupPars$lhs[j],rows),match(GroupPars$rhs[j],cols)] <- GroupPars$fixed[j] 42 | ResMatrix[[i]]$par[match(GroupPars$lhs[j],rows),match(GroupPars$rhs[j],cols)] <- GroupPars$par[j] 43 | } 44 | } 45 | } 46 | names(ResMatrix) <- Groups 47 | return(ResMatrix) 48 | } 49 | 50 | 51 | FilterMatrix <- function(Pars, Vars) 52 | { 53 | Groups <- unique(Pars$group) 54 | 55 | ResMatrix <- list() 56 | Nvar <- nrow(Vars) 57 | Nman <- sum(Vars$manifest) 58 | 59 | for (i in seq_along(Groups)) 60 | { 61 | ResMatrix[[i]] <- list() 62 | ResMatrix[[i]]$est <- cbind(diag(1,Nman),matrix(0,Nman,Nvar-Nman)) 63 | ResMatrix[[i]]$est[,order(Vars$manifest,decreasing=TRUE)] <- ResMatrix[[i]]$est 64 | rownames(ResMatrix[[i]]$est) <- Vars$name[Vars$manifest] 65 | colnames(ResMatrix[[i]]$est) <- Vars$name 66 | } 67 | 68 | names(ResMatrix) <- Groups 69 | return(ResMatrix) 70 | } -------------------------------------------------------------------------------- /R/amos.R: -------------------------------------------------------------------------------- 1 | 2 | semPlotModel_Amos <- function(object) 3 | { 4 | ## Warnings: 5 | warning("(Residual) variances of Amos model is not yet supported") 6 | 7 | # Read characters: 8 | str <- readChar(object,nchars=file.info(object)$size) 9 | 10 | # Extract Estimates section: 11 | estLocs <- gregexpr('
',str)[[1]] 12 | nModel <- length(estLocs) 13 | Parss <- list() 14 | 15 | # Open and close div: 16 | open <- gregexpr("",str)[[1]] 18 | 19 | for (mod in 1:nModel) 20 | { 21 | startSect <- which(open==estLocs[mod]) 22 | # Find title: 23 | titleString <- substring(str,open[startSect+1],close[which(close>open[startSect+1])[1]]) 24 | modName <- regmatches(titleString,regexpr("(?<=
).*?(?=
)",titleString,perl=TRUE)) 25 | 26 | # Find close: 27 | nest <- 1 28 | curOpen <- startSect + 1 29 | curClose <- which(close>open[curOpen])[1] 30 | repeat{ 31 | # If next is opened: 32 | if (open[curOpen] < close[curClose]) 33 | { 34 | nest <- nest + 1 35 | curOpen <- curOpen + 1 36 | } else { 37 | # If next is closed: 38 | nest <- nest - 1 39 | if (nest==0) break 40 | curClose <- curClose + 1 41 | } 42 | } 43 | EstTabs <- substring(str,open[startSect],close[curClose] + 5) 44 | 45 | # Extract tables: 46 | Tabs <- readHTMLTable(EstTabs) 47 | 48 | # Find names of tables; 49 | Tabspl <- strsplit(EstTabs,split="")[[1]] 50 | Names <- regmatches(Tabspl,gregexpr('(?<=nodecaption=").*(?=">)',Tabspl,perl=TRUE))[-length(Tabspl)] 51 | Names <- sapply(Names,function(x)x[length(x)]) 52 | 53 | names(Tabs) <- Names 54 | 55 | # Regression weights: 56 | Reg <- Tabs[[which(grepl("regression",names(Tabs),ignore.case=TRUE))[1]]] 57 | Reg <- as.data.frame(lapply(Reg,as.character),stringsAsFactors=FALSE) 58 | if (is.null(Reg$Estimate)) Reg$Estimate <- 1 59 | if (is.null(Reg$Label)) Reg$Label <- "" 60 | 61 | # Make Pars: 62 | # Define Pars: 63 | Pars <- data.frame( 64 | label = Reg$Label, 65 | lhs = Reg[,3], 66 | edge = "->", 67 | rhs = Reg[,1], 68 | est = as.numeric(gsub(",",".",Reg$Estimate)), 69 | std = NA, 70 | group = modName, 71 | fixed = FALSE, 72 | par = 0, 73 | stringsAsFactors=FALSE) 74 | 75 | # Pars$par <- 1:nrow(Pars) 76 | Pars$label[is.na(Pars$label)] <- "" 77 | 78 | # # Fix edges: 79 | # Pars$edge[Reg[,2]=="<---"] <- "->" 80 | # Pars$edge[Reg[,2]=="<-->"] <- "<->" 81 | 82 | # Test for fixed: 83 | if (!is.null(Reg$P)) Pars$fixed <- is.na(Reg$P) 84 | 85 | # Standardized values: 86 | if (any(grepl("standardized",names(Tabs),ignore.case=TRUE))) 87 | { 88 | Std <- Tabs[[which(grepl("standardized",names(Tabs),ignore.case=TRUE))[1]]] 89 | Std <- as.data.frame(lapply(Std,as.character),stringsAsFactors=FALSE) 90 | if (is.null(Std$Estimate)) Std$Estimate <- 1 91 | Pars$std <- as.numeric(gsub(",",".",Std$Estimate)) 92 | } 93 | 94 | # Add covariances: 95 | if (any(grepl("covariance",names(Tabs),ignore.case=TRUE))) 96 | { 97 | Cov <- Tabs[[which(grepl("covariance",names(Tabs),ignore.case=TRUE))[1]]] 98 | Cov <- as.data.frame(lapply(Cov,as.character),stringsAsFactors=FALSE) 99 | if (is.null(Cov$Estimate)) Cov$Estimate <- 1 100 | if (is.null(Cov$Label)) Cov$Label <- "" 101 | 102 | covPars <- data.frame( 103 | label = Cov$Label, 104 | lhs = Cov[,3], 105 | edge = "<->", 106 | rhs = Cov[,1], 107 | est = as.numeric(gsub(",",".",Cov$Estimate)), 108 | std = NA, 109 | group = modName, 110 | fixed = FALSE, 111 | par = 0, 112 | stringsAsFactors=FALSE) 113 | 114 | if (!is.null(Cov$P)) covPars$fixed <- is.na(Cov$P) 115 | 116 | # Check cors: 117 | if (any(grepl("correlation",names(Tabs),ignore.case=TRUE))) 118 | { 119 | Cor <- Tabs[[which(grepl("correlation",names(Tabs),ignore.case=TRUE))[1]]] 120 | Cor <- as.data.frame(lapply(Cor,as.character),stringsAsFactors=FALSE) 121 | if (is.null(Cor$Estimate)) Cor$Estimate <- 1 122 | covPars$std <- Cor$Estimate 123 | } 124 | Pars <- rbind(Pars,covPars) 125 | } 126 | 127 | Parss[[mod]] <- Pars 128 | } 129 | 130 | Pars <- do.call(rbind,Parss) 131 | Pars$par <- 1:nrow(Pars) 132 | 133 | ## Extract variable info: 134 | startSect <- which(open==gregexpr('
open[curOpen])[1] 138 | repeat{ 139 | # If next is opened: 140 | if (open[curOpen] < close[curClose]) 141 | { 142 | nest <- nest + 1 143 | curOpen <- curOpen + 1 144 | } else { 145 | nest <- nest - 1 146 | if (nest==0) break 147 | curClose <- curClose + 1 148 | } 149 | } 150 | VarList <- substring(str,open[startSect],close[curClose] + 5) 151 | # Reove html tags: 152 | VarList <- gsub("<(.|\n)*?>","",VarList) 153 | # Per line: 154 | VarList <- scan(text=VarList,what="character",sep="\n") 155 | # Remove leading and trailing whitespace: 156 | VarList <- gsub("^\\s*","",VarList) 157 | VarList <- gsub("\\s*$","",VarList) 158 | 159 | AllVars <- unique(c(Pars$lhs,Pars$rhs)) 160 | AllVars <- AllVars[AllVars!=""] 161 | 162 | # Location of indicators: 163 | # manEndo - latEndo - manExo - latExo 164 | grepRep <- function(...) 165 | { 166 | res <- grep(...) 167 | if (length(res)==0) res <- -1 168 | return(res[1]) 169 | } 170 | ind <- c( 171 | grepRep("Observed, endogenous variables",VarList), 172 | grepRep("Unobserved, endogenous variables",VarList), 173 | grepRep("Observed, exogenous variables",VarList), 174 | grepRep("Unobserved, exogenous variables",VarList)) 175 | 176 | if (ind[1] > 0) 177 | { 178 | manEndo <- VarList[(ind[1]+1):(which((1:length(VarList) == length(VarList)) | (1:length(VarList) > ind[1]+1 & 1:length(VarList) %in% ind))[1] - 1)] 179 | } else manEndo <- character(0) 180 | 181 | if (ind[2] > 0) 182 | { 183 | latEndo <- VarList[(ind[2]+1):(which((1:length(VarList) == length(VarList)) | (1:length(VarList) > ind[2]+1 & 1:length(VarList) %in% ind))[1] - 1)] 184 | } else latEndo <- character(0) 185 | 186 | if (ind[3] > 0) 187 | { 188 | manExo <- VarList[(ind[3]+1):(which((1:length(VarList) == length(VarList)) | (1:length(VarList) > ind[3]+1 & 1:length(VarList) %in% ind))[1] - 1)] 189 | } else manExo <- character(0) 190 | 191 | if (ind[4] > 0) 192 | { 193 | latExo <- VarList[(ind[4]+1):(which((1:length(VarList) == length(VarList)) | (1:length(VarList) > ind[4]+1 & 1:length(VarList) %in% ind))[1] - 1)] 194 | } else latExo <- character(0) 195 | 196 | Vars <- data.frame( 197 | name = c(manEndo,manExo,latEndo,latExo), 198 | manifest = c(rep(TRUE,length(c(manEndo,manExo))),rep(FALSE,length(c(latEndo,latExo)))), 199 | exogenous = c(rep(FALSE,length(manEndo)),rep(TRUE,length(manExo)),rep(FALSE,length(latEndo)),rep(TRUE,length(latExo))), 200 | stringsAsFactors=FALSE) 201 | 202 | 203 | 204 | # Return: 205 | semModel <- new("semPlotModel") 206 | semModel@Pars <- Pars 207 | semModel@Vars <- Vars 208 | semModel@Computed <- FALSE 209 | semModel@Original <- list(str) 210 | semModel@ObsCovs <- list() 211 | semModel@ImpCovs <- list() 212 | # semModel@Thresholds <- Thresh 213 | 214 | return(semModel) 215 | } -------------------------------------------------------------------------------- /R/cvregsemplot.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | semPlotModel.cvregsem <- function(object,model,...){ 4 | if (missing(model)){ 5 | stop("Please supply lavaan model with 'model' argument!") 6 | } 7 | ## Save parts of the output in objects 8 | object1 <- object # parameters 9 | object2 <- model@ParTable # lavaan parameters 10 | varnames <- unique(c(object2$lhs, object2$rhs)) # all names 11 | mannames <- model@Model@dimNames[[1]][1] # manifest variables 12 | names(varnames) <- 'name' 13 | names(mannames) <- 'manifest' 14 | 15 | '%!in%' <- function(x,y)!('%in%'(x,y)) 16 | 17 | ## Add the fixed relations to the parameter estimates of regsem 18 | namelist <- strsplit(names(object1$final_pars)," ") # split names and operators 19 | inout <- data.frame(1,2) 20 | for(i in 1:length(namelist)){ 21 | inout[i,1] <- namelist[[i]][1] 22 | inout[i,2] <- namelist[[i]][3] 23 | } # create data frame of regsem variables 24 | 25 | int <- data.frame(1,2) 26 | for(i in 1:length(object2$lhs)){ 27 | int[i,1] <- ifelse(object2$op[i]=="~"|object2$op[i]=="~1",object2$rhs[i],object2$lhs[i]) 28 | int[i,2] <- ifelse(object2$op[i]=="~"|object2$op[i]=="~1",object2$lhs[i],object2$rhs[i]) 29 | } # create data frame of lavaan variables 30 | 31 | ## paste together 32 | pinout <- with(inout, paste0(X1, X2)) 33 | pint <- with(int, paste0(X1, X2)) 34 | 35 | counter <- 0 36 | for(i in 1:length(object2$free)){ # if free before, 37 | if(object2$free[i] == 0){ 38 | object1$regest[i] <- 1 39 | counter = counter + 1 40 | } else{ 41 | object1$regest[i] <- object1$final_pars[i - counter] 42 | } 43 | } # match regsem estimates with lavaan variables, set fixed to 1 44 | 45 | 46 | ## Create a S4 list 47 | semModel <- new("semPlotModel") 48 | 49 | ## Create a Pars data frame 50 | semModel@Pars <- data.frame( 51 | label = rep("", length(object2$id)), 52 | lhs = ifelse(object2$op=="~"|object2$op=="~1",object2$rhs,object2$lhs), # first went from left to right without checking relationship 53 | edge = "--", 54 | rhs = ifelse(object2$op=="~"|object2$op=="~1",object2$lhs,object2$rhs), 55 | est = object1$regest, # check if we should take estimates from other model, if estimates are same as in regsem 56 | std = NA, 57 | group = object2$group, 58 | fixed = object2$free == 0, 59 | par = object2$free, 60 | stringsAsFactors=FALSE) 61 | row.names(semModel@Pars) <- 1:length(object2$id) 62 | 63 | ## translate operators 64 | semModel@Pars$edge[object2$op=="~~"] <- "<->" 65 | semModel@Pars$edge[object2$op=="~*~"] <- "<->" 66 | semModel@Pars$edge[object2$op=="~"] <- "~>" 67 | semModel@Pars$edge[object2$op=="=~"] <- "->" 68 | semModel@Pars$edge[object2$op=="~1"] <- "int" 69 | semModel@Pars$edge[grepl("\\|",object2$op)] <- "|" 70 | 71 | semModel@Pars <- semModel@Pars[!object2$op%in%c(':=','<','>','==','|','<', '>'),] 72 | 73 | ## Create a vars data frame 74 | semModel@Vars <- data.frame( 75 | name = varnames, 76 | manifest = varnames[1:length(varnames)] %in% mannames$manifest[1:length(mannames$manifest)], 77 | exogenous = NA, 78 | stringsAsFactors = FALSE 79 | ) 80 | 81 | ## Miscellaneous data frames 82 | semModel@Thresholds <- data.frame() 83 | semModel@ObsCovs <- list() 84 | semModel@ImpCovs <- list() 85 | semModel@Computed <- FALSE 86 | semModel@Original <- list(object) 87 | 88 | return(semModel) 89 | } 90 | -------------------------------------------------------------------------------- /R/defExo.R: -------------------------------------------------------------------------------- 1 | defExo <- function(object,layout="tree") 2 | { 3 | manNames <- object@Vars$name[object@Vars$manifest] 4 | latNames <- object@Vars$name[!object@Vars$manifest] 5 | 6 | # Define exogenous variables (only if any is NA): 7 | if (any(is.na(object@Vars$exogenous))) 8 | { 9 | if (any(!is.na(object@Vars$exogenous))) 10 | { 11 | exoOrig <- object@Vars$exogenous 12 | repExo <- TRUE 13 | } else repExo <- FALSE 14 | object@Vars$exogenous <- FALSE 15 | for (i in which(!object@Vars$manifest)) 16 | { 17 | 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)) 18 | { 19 | object@Vars$exogenous[i] <- TRUE 20 | } 21 | } 22 | for (i in which(object@Vars$manifest)) 23 | { 24 | if (all(object@Pars$lhs[object@Pars$rhs==object@Vars$name[i] & object@Pars$lhs%in%latNames]%in%object@Vars$name[object@Vars$exogenous]) & 25 | all(object@Pars$rhs[object@Pars$lhs==object@Vars$name[i] & object@Pars$rhs%in%latNames]%in%object@Vars$name[object@Vars$exogenous]) & 26 | !any(object@Pars$rhs==object@Vars$name[i] & object@Pars$edge=="~>")) 27 | { 28 | object@Vars$exogenous[i] <- TRUE 29 | } 30 | } 31 | 32 | # If all exo, treat all as endo: 33 | if (all(object@Vars$exogenous) | layout%in%c("circle","circle2","circle3")) 34 | { 35 | object@Vars$exogenous <- FALSE 36 | } 37 | # If al endo, treat formative manifest as exo (MIMIC mode), unless all manifest are formative. 38 | if (!any(object@Vars$exogenous)) 39 | { 40 | if (any(object@Vars$manifest & (object@Vars$name%in%object@Pars$rhs[object@Pars$edge %in% c("~>","--","->")]))) 41 | object@Vars$exogenous[object@Vars$manifest & !(object@Vars$name%in%object@Pars$rhs[object@Pars$edge %in% c("~>","--","->")])] <- TRUE 42 | } 43 | if (repExo) 44 | { 45 | object@Vars$exogenous[!is.na(exoOrig)] <- exoOrig[!is.na(exoOrig)] 46 | } 47 | } 48 | 49 | return(object) 50 | } -------------------------------------------------------------------------------- /R/editFuns.R: -------------------------------------------------------------------------------- 1 | # Extract exogenous variables: 2 | exo <- function(x) 3 | { 4 | if (!"semPlotModel"%in%class(x)) stop("'semPlotModel' object is required") 5 | x@Vars$name[!is.na(x@Vars$exogenous)][x@Vars$exogenous[!is.na(x@Vars$exogenous)]] 6 | } 7 | 8 | # Set exogenous variables: 9 | "exo<-" <- function(x,value) 10 | { 11 | if (!"semPlotModel"%in%class(x)) stop("'semPlotModel' object is required") 12 | x@Vars$name[!is.na(x@Vars$exogenous)][x@Vars$exogenous[!is.na(x@Vars$exogenous)]] <- FALSE 13 | x@Vars$exogenous[x@Vars$name%in%value] <- TRUE 14 | return(x) 15 | } 16 | 17 | # Extract endogenous variables: 18 | endo <- function(x) 19 | { 20 | if (!"semPlotModel"%in%class(x)) stop("'semPlotModel' object is required") 21 | x@Vars$name[!is.na(x@Vars$exogenous)][!x@Vars$exogenous[!is.na(x@Vars$exogenous)]] 22 | } 23 | 24 | # Set endogenous variables: 25 | "endo<-" <- function(x,value) 26 | { 27 | if (!"semPlotModel"%in%class(x)) stop("'semPlotModel' object is required") 28 | x@Vars$name[!is.na(x@Vars$exogenous)][!x@Vars$exogenous[!is.na(x@Vars$exogenous)]] <- TRUE 29 | x@Vars$exogenous[x@Vars$name%in%value] <- FALSE 30 | return(x) 31 | } 32 | 33 | # Extract manifest variables: 34 | man <- function(x) 35 | { 36 | if (!"semPlotModel"%in%class(x)) stop("'semPlotModel' object is required") 37 | x@Vars$name[x@Vars$manifest] 38 | } 39 | 40 | # Set manifest variables: 41 | "man<-" <- function(x,value) 42 | { 43 | if (!"semPlotModel"%in%class(x)) stop("'semPlotModel' object is required") 44 | x@Vars$manifest[x@Vars$name%in%value] <- TRUE 45 | return(x) 46 | } 47 | 48 | # Extract latent variables: 49 | lat <- function(x) 50 | { 51 | if (!"semPlotModel"%in%class(x)) stop("'semPlotModel' object is required") 52 | x@Vars$name[!x@Vars$manifest] 53 | } 54 | 55 | # Set latent variables: 56 | "lat<-" <- function(x,value) 57 | { 58 | if (!"semPlotModel"%in%class(x)) stop("'semPlotModel' object is required") 59 | x@Vars$manifest[x@Vars$name%in%value] <- FALSE 60 | return(x) 61 | } -------------------------------------------------------------------------------- /R/factanal.R: -------------------------------------------------------------------------------- 1 | # semPaths.factanal <- function(object,...) 2 | # { 3 | # invisible(semPaths(semPlotModel(object),...)) 4 | # } 5 | # 6 | 7 | 8 | ### SINGLE GROUP MODEL ### 9 | semPlotModel.factanal <- function(object, ...) 10 | { 11 | 12 | # Check if object is of class "sem": 13 | if (!"factanal"%in%class(object)) stop("Input must be a 'factanal' object") 14 | 15 | 16 | # Extract model: 17 | mod <- semPlotModel(loadings(object)) 18 | manNames <- mod@Vars$name[mod@Vars$manifest] 19 | 20 | # Fix: 21 | mod@Pars$edge <- "->" 22 | 23 | # Add residuals: 24 | Uniqueness <- object$uniquenesses 25 | 26 | residPars <- data.frame( 27 | label = "", 28 | lhs = manNames, 29 | edge = "<->", 30 | rhs = manNames, 31 | est = Uniqueness, 32 | std = Uniqueness, 33 | group = "", 34 | fixed = FALSE, 35 | par = 0, 36 | stringsAsFactors=FALSE) 37 | 38 | mod@Pars <- rbind(mod@Pars,residPars) 39 | mod@Pars$par <- 1:nrow(mod@Pars) 40 | 41 | 42 | return(mod) 43 | } 44 | 45 | -------------------------------------------------------------------------------- /R/glm.R: -------------------------------------------------------------------------------- 1 | 2 | semPlotModel.lm <- function(object, ...) 3 | { 4 | coef <- as.matrix(coef(object)) 5 | Nr <- nrow(coef) 6 | Nc <- ncol(coef) 7 | 8 | combLetters <- function(x) 9 | { 10 | if (length(x)>1) return(sapply(x,combLetters)) 11 | 12 | f <- function(x) 13 | { 14 | if (x[1]>26) c(f(floor(x/26)),x%%26 + 1) else x 15 | } 16 | 17 | paste(LETTERS[f(x)],collapse="") 18 | } 19 | 20 | if (is.null(rownames(coef))) 21 | { 22 | rownames(coef) <- names(object$model)[(Nc+1):length(object$model)] 23 | } 24 | 25 | if (is.null(colnames(coef))) 26 | { 27 | colnames(coef) <- names(object$model)[1:Nc] 28 | } 29 | 30 | namesCoef <- rownames(coef) 31 | stdCoef <- coef(standardize(object)) 32 | names(stdCoef) <- gsub("`","",names(stdCoef)) 33 | 34 | NamesR <- rownames(coef) 35 | NamesC <- colnames(coef) 36 | 37 | 38 | Pars <- data.frame( 39 | label = "", 40 | lhs = rep(NamesR,times=Nc), 41 | edge = "->", 42 | rhs = rep(NamesC,each=Nr), 43 | est = c(coef), 44 | std = unname(c(stdCoef[paste0(namesCoef,"s")])), 45 | group = "", 46 | fixed = FALSE, 47 | par = 1:(Nr*Nc), 48 | knot = 0, 49 | stringsAsFactors=FALSE) 50 | 51 | ## Split interactions: 52 | if (any(grepl(":",Pars$lhs))) 53 | { 54 | colons <- grep(":",Pars$lhs) 55 | for (i in seq_along(colons)) 56 | { 57 | labs <- strsplit(Pars$lhs[colons[i]],split=":")[[1]] 58 | Pars$lhs[colons[i]] <- labs[1] 59 | Pars$knot[colons[i]] <- i 60 | for (j in 2:length(labs)) 61 | { 62 | Pars <- rbind(Pars,Pars[colons[i],]) 63 | Pars$lhs[nrow(Pars)] <- labs[j] 64 | } 65 | } 66 | } 67 | 68 | Pars$edge[grepl("intercept",Pars$lhs,ignore.case=TRUE)] <- "int" 69 | Pars$lhs[grepl("intercept",Pars$lhs,ignore.case=TRUE)] <- "" 70 | 71 | # Variable dataframe: 72 | Vars <- data.frame( 73 | name = unique(c(Pars$lhs,Pars$rhs)), 74 | manifest = TRUE, 75 | exogenous = NA, 76 | stringsAsFactors=FALSE) 77 | Vars <- Vars[Vars$name!="",] 78 | 79 | semModel <- new("semPlotModel") 80 | semModel@Pars <- Pars 81 | semModel@Vars <- Vars 82 | semModel@Computed <- TRUE 83 | semModel@Original <- list(object) 84 | semModel@ObsCovs <- list() 85 | semModel@ImpCovs <- list() 86 | 87 | return(semModel) 88 | } -------------------------------------------------------------------------------- /R/greplVarType.R: -------------------------------------------------------------------------------- 1 | # grepl on varnames with special keywords: 2 | # - MAN 3 | # - LAT 4 | # - ENDO 5 | # - EXO 6 | # - INT 7 | 8 | matchVar <- function(x, Vars, manIntsExo, manIntsEndo, latIntsExo, latIntsEndo) 9 | { 10 | 11 | n <- nrow(Vars) + nrow(manIntsEndo) + nrow(manIntsExo) + nrow(latIntsEndo) + nrow(latIntsExo) 12 | 13 | Man <- c(Vars$manifest, rep(FALSE,n-nrow(Vars))) 14 | Man[c(manIntsEndo[,1],manIntsExo[,1])] <- TRUE 15 | 16 | Exo <- c(Vars$exogenous, rep(FALSE,n-nrow(Vars))) 17 | Exo[c(manIntsExo[,1],latIntsExo[,1])] <- TRUE 18 | 19 | isInt <- c(rep(FALSE,nrow(Vars)), rep(TRUE, n-nrow(Vars))) 20 | 21 | # match: 22 | matchRes <- match(x,Vars$name) 23 | matchRes <- matchRes[!is.na(matchRes)] 24 | 25 | # keywords: 26 | select <- rep(grepl("(EXO)|(ENDO)|(MAN)|(LAT)|(INT)|(VAR)",x),n) 27 | 28 | if (any(select)) 29 | { 30 | 31 | if (grepl("(ENDO)|(EXO)",x)) 32 | { 33 | # First node first / endo: 34 | select <- select & ((grepl("ENDO",x) & !Exo) | 35 | (grepl("EXO",x) & Exo ) 36 | ) 37 | } 38 | 39 | if (grepl("(LAT)|(MAN)",x)) 40 | { 41 | 42 | # Any node man / latent 43 | select <- select & ((grepl("LAT",x) & !Man) | 44 | (grepl("MAN",x) & Man ) 45 | ) 46 | } 47 | 48 | if (grepl("(INT)|(VAR)",x)) 49 | { 50 | 51 | # Any node man / latent 52 | select <- select & ((grepl("VAR",x) & !isInt) | 53 | (grepl("INT",x) & isInt ) 54 | ) 55 | } 56 | 57 | } 58 | 59 | return(c(matchRes,which(select))) 60 | } -------------------------------------------------------------------------------- /R/isColor.R: -------------------------------------------------------------------------------- 1 | isColor <- function(x) { 2 | sapply(x, function(X) { 3 | if (!is.logical(X)) tryCatch(is.matrix(col2rgb(X)), 4 | error = function(e) FALSE) else FALSE 5 | }) 6 | } 7 | -------------------------------------------------------------------------------- /R/lavaan.R: -------------------------------------------------------------------------------- 1 | ### Path diagrams ### 2 | # 3 | # setMethod("semPaths.S4",signature("lavaan"),function(object,...){ 4 | # invisible(semPaths(semPlotModel(object),...)) 5 | # }) 6 | # 7 | 8 | 9 | ## EXTRACT MODEL ### 10 | setMethod("semPlotModel_S4",signature("lavaan"),function(object){ 11 | 12 | if (is(object,"blavaan")) class(object) <- 'lavaan' 13 | if (!is(object,"lavaan")) stop("Input must me a 'lavaan' object") 14 | 15 | 16 | # Extract parameter estimates: 17 | pars <- parameterEstimates(object,standardized=TRUE) 18 | list <- inspect(object,"list") 19 | 20 | # Remove mean structure (TEMP SOLUTION) 21 | # meanstructure <- pars$op=="~1" 22 | # pars <- pars[!meanstructure,] 23 | 24 | # Extract variable and factor names: 25 | # varNames <- fit@Model@dimNames$lambda[[1]] 26 | # factNames <- fit@Model@dimNames$lambda[[2]] 27 | # Lambda <- inspect(object,"coef")$lambda 28 | varNames <- lavaanNames(object, type="ov") 29 | factNames <- lavaanNames(object, type="lv") 30 | # rm(Lambda) 31 | 32 | factNames <- factNames[!factNames%in%varNames] 33 | 34 | # Extract number of variables and factors 35 | n <- length(varNames) 36 | k <- length(factNames) 37 | 38 | # Extract parameter names: 39 | if (is.null(pars$label)) pars$label <- rep("",nrow(pars)) 40 | 41 | semModel <- new("semPlotModel") 42 | 43 | if (is.null(pars$group)) pars$group <- "" 44 | 45 | # Create edges dataframe 46 | semModel@Pars <- data.frame( 47 | label = pars$label, 48 | lhs = ifelse(pars$op=="~"|pars$op=="~1",pars$rhs,pars$lhs), 49 | edge = "--", 50 | rhs = ifelse(pars$op=="~"|pars$op=="~1",pars$lhs,pars$rhs), 51 | est = pars$est, 52 | std = pars$std.all, 53 | group = pars$group, 54 | fixed = list$free[list$op!="=="]==0, 55 | par = list$free[list$op!="=="], 56 | stringsAsFactors=FALSE) 57 | 58 | 59 | semModel@Pars$edge[pars$op=="~~"] <- "<->" 60 | semModel@Pars$edge[pars$op=="~*~"] <- "<->" 61 | semModel@Pars$edge[pars$op=="~"] <- "~>" 62 | semModel@Pars$edge[pars$op=="=~"] <- "->" 63 | semModel@Pars$edge[pars$op=="~1"] <- "int" 64 | semModel@Pars$edge[grepl("\\|",pars$op)] <- "|" 65 | 66 | # Move thresholds to Thresholds slot: 67 | semModel@Thresholds <- semModel@Pars[grepl("\\|",semModel@Pars$edge),-(3:4)] 68 | 69 | # Remove constraints and weird stuff: 70 | semModel@Pars <- semModel@Pars[!pars$op %in% c('<', '>',':=','<','>','==','|'),] 71 | 72 | # Remove thresholds from Pars: 73 | # semModel@Pars <- semModel@Pars[!grepl("\\|",semModel@Pars$edge),] 74 | 75 | semModel@Vars <- data.frame( 76 | name = c(varNames,factNames), 77 | manifest = c(varNames,factNames)%in%varNames, 78 | exogenous = NA, 79 | stringsAsFactors=FALSE) 80 | 81 | # res.cov <- lavTech(object, "sampstat")$res.cov 82 | # lavTech(object, "sampstat")$cov 83 | # if (!is.null(res.cov) && !length(res.cov) == 0){ 84 | # if (!is.null(res.cov[[1]])){ 85 | # semModel@ObsCovs <- object@SampleStats@res.cov 86 | # } else { 87 | # semModel@ObsCovs <- object@SampleStats@cov 88 | # } 89 | # } else { 90 | # semModel@ObsCovs <- list(matrix(NA, 91 | # length(varNames),length(varNames))) 92 | # } 93 | 94 | if (lavInspect(object, "options")$conditional.x){ 95 | semModel@ObsCovs <- lapply(lavTech(object, "sampstat"),"[[","res.cov") 96 | } else { 97 | semModel@ObsCovs <- lapply(lavTech(object, "sampstat"),"[[","cov") 98 | } 99 | 100 | names(semModel@ObsCovs) <- lavInspect(object, "group.label") 101 | for (i in 1:length(semModel@ObsCovs)) 102 | { 103 | rownames(semModel@ObsCovs[[i]]) <- colnames(semModel@ObsCovs[[i]]) <- lavaanNames(object, type="ov") #object@Data@ov.names[[i]] 104 | } 105 | 106 | semModel@ImpCovs <- lapply(lavTech(object, "implied"), "[[", "cov") 107 | names(semModel@ImpCovs) <- lavInspect(object, "group.label") # object@Data@group.label 108 | 109 | for (i in 1:length(semModel@ImpCovs)) 110 | { 111 | rownames(semModel@ImpCovs[[i]]) <- colnames(semModel@ImpCovs[[i]]) <- lavaanNames(object, type="ov") 112 | } 113 | 114 | semModel@Computed <- TRUE 115 | 116 | semModel@Original <- list(object) 117 | 118 | return(semModel) 119 | }) 120 | 121 | 122 | 123 | -------------------------------------------------------------------------------- /R/lavaanModel.R: -------------------------------------------------------------------------------- 1 | ### Path diagrams ### 2 | # 3 | # setMethod("semPaths.S4",signature("lavaan"),function(object,...){ 4 | # invisible(semPaths(semPlotModel(object),...)) 5 | # }) 6 | # 7 | 8 | 9 | ## EXTRACT MODEL ### 10 | semPlotModel_lavaanModel <- function(object, ...) 11 | { 12 | 13 | # Check if parTable, otherwise run lavaanify: 14 | if (!is.data.frame(object) & !is.list(object)) 15 | { 16 | object <- lavaanify(object, ...) 17 | } 18 | 19 | varNames <- lavaanNames(object, type="ov") 20 | factNames <- lavaanNames(object, type="lv") 21 | # rm(Lambda) 22 | 23 | factNames <- factNames[!factNames%in%varNames] 24 | 25 | # Extract number of variables and factors 26 | n <- length(varNames) 27 | k <- length(factNames) 28 | 29 | # Extract parameter names: 30 | if (is.null(object$label)) object$label <- rep("",nrow(object)) 31 | 32 | semModel <- new("semPlotModel") 33 | 34 | # Set estimates to 1 or ustart: 35 | object$est <- ifelse(is.na(object$ustart),1,object$ustart) 36 | 37 | if (is.null(object$group)) object$group <- "" 38 | 39 | # Create edges dataframe 40 | semModel@Pars <- data.frame( 41 | label = object$label, 42 | lhs = ifelse(object$op=="~"|object$op=="~1",object$rhs,object$lhs), 43 | edge = "--", 44 | rhs = ifelse(object$op=="~"|object$op=="~1",object$lhs,object$rhs), 45 | est = object$est, 46 | std = NA, 47 | group = object$group, 48 | fixed = object$free==0, 49 | par = object$free, 50 | stringsAsFactors=FALSE) 51 | 52 | semModel@Pars$edge[object$op=="~~"] <- "<->" 53 | semModel@Pars$edge[object$op=="~*~"] <- "<->" 54 | semModel@Pars$edge[object$op=="~"] <- "~>" 55 | semModel@Pars$edge[object$op=="=~"] <- "->" 56 | semModel@Pars$edge[object$op=="~1"] <- "int" 57 | semModel@Pars$edge[grepl("\\|",object$op)] <- "|" 58 | 59 | # Move thresholds to Thresholds slot: 60 | semModel@Thresholds <- semModel@Pars[grepl("\\|",semModel@Pars$edge),-(3:4)] 61 | # Remove thresholds from Pars: 62 | # semModel@Pars <- semModel@Pars[!grepl("\\|",semModel@Pars$edge),] 63 | 64 | # Remove weird edges: 65 | semModel@Pars <- semModel@Pars[!object$op%in%c(':=','<','>','==','|','<', '>'),] 66 | 67 | 68 | semModel@Vars <- data.frame( 69 | name = c(varNames,factNames), 70 | manifest = c(varNames,factNames)%in%varNames, 71 | exogenous = NA, 72 | stringsAsFactors=FALSE) 73 | 74 | semModel@ObsCovs <- list() 75 | semModel@ImpCovs <- list() 76 | semModel@Computed <- FALSE 77 | semModel@Original <- list(object) 78 | 79 | return(semModel) 80 | } 81 | 82 | 83 | 84 | -------------------------------------------------------------------------------- /R/lisrelMat2RAM.R: -------------------------------------------------------------------------------- 1 | modMat2Pars <- function(x,edge,exprname,symmetric=FALSE,vec=FALSE,cols,rows,group="",exprsup="") 2 | { 3 | # Define x Pars: 4 | if (length(x)>0) 5 | { 6 | if (symmetric) 7 | { 8 | if (!isSymmetric(x$est)) stop(paste0("'",deparse(substitute(x)),"' matrix must be symmetrical.")) 9 | x$est[upper.tri(x$est)] <- 0 10 | } 11 | 12 | Pars <- data.frame( 13 | label = "", 14 | lhs = rep(cols,each=length(rows)), 15 | edge = edge, 16 | rhs = rep(rows,times=length(cols)), 17 | est = c(x$est), 18 | std = NA, 19 | group = group, 20 | fixed = FALSE, 21 | par = 0, 22 | stringsAsFactors=FALSE) 23 | 24 | if (!vec) 25 | { 26 | Pars$label <- c(outer(1:nrow(x$est),1:ncol(x$est),function(x,y)paste0(exprname,"[",x,y,"]",exprsup))) 27 | } else { 28 | Pars$label <- paste0(exprname,"[",1:length(x$est),"]",exprsup) 29 | } 30 | if (!is.null(x[['std']])) 31 | { 32 | Pars[['std']] <- c(x[['std']]) 33 | } 34 | if (!is.null(x[['par']])) 35 | { 36 | Pars[['par']] <- c(x[['par']]) 37 | } 38 | if (!is.null(x[['fixed']])) 39 | { 40 | Pars[['fixed']] <- c(x[['fixed']]) 41 | } 42 | 43 | } else Pars <- data.frame( 44 | label = character(0), 45 | lhs = character(0), 46 | edge = character(0), 47 | rhs = character(0), 48 | est = numeric(0), 49 | std = numeric(0), 50 | group = character(0), 51 | fixed = logical(0), 52 | par = numeric(0), 53 | stringsAsFactors=FALSE) 54 | 55 | return(Pars) 56 | } 57 | 58 | -------------------------------------------------------------------------------- /R/lisrelModel.R: -------------------------------------------------------------------------------- 1 | semPlotModel.lisrel <- function(object,...) 2 | { 3 | Res <- do.call(lisrelModel, c(object$matrices,list(...))) 4 | Res@Original <- list(object) 5 | return(Res) 6 | } 7 | 8 | InvEmp <- function(x) 9 | { 10 | if (any(dim(x)==0)) 11 | { 12 | return(array(0,dim=dim(x))) 13 | } else { 14 | res <- tryCatch(solve(x), error = function(e) FALSE, silent = TRUE) 15 | if (is.matrix(res)) return(res) else 16 | { 17 | res <- tryCatch(pseudoinverse(x), error = function(e) FALSE, silent = TRUE) 18 | if (is.matrix(res)) 19 | { 20 | warning("Psuedoinverse used for singular matrix. Standardized solution might not be proper.") 21 | return(res) 22 | } else 23 | { 24 | warning("Uninvertable matrix found and psuedoinverse could not be computed. Standardized solutions probably not proper.") 25 | return(array(0, dim=dim(x))) 26 | } 27 | } 28 | } 29 | } 30 | 31 | fixMatrix <- function(m) 32 | { 33 | # If not a list (matrix itself added) put matrix in list (group 1) in list: 34 | if (!is.list(m)) 35 | { 36 | if (is.matrix(m)|is.vector(m)) 37 | { 38 | m <- list(list(est=m)) 39 | } else stop("Wrong input for matrix") 40 | } else if ("est"%in%names(m)) { 41 | # Else if list, check if it is not a list of lists 42 | m <- list(m) 43 | } 44 | 45 | # Else check if empty list: 46 | if (length(m)>0) 47 | { 48 | # Assume multigroup. Check if all elements are list: 49 | if (!all(sapply(m,is.list))) stop("Not all elements are a list") 50 | 51 | # Clean each group: 52 | for (g in seq_along(m)) 53 | { 54 | # Copy parSpec to par (lisrelToR compatibility) 55 | if (is.empty(m[[g]][['par']]) & !is.empty(m[[g]][['parSpec']])) 56 | { 57 | m[[g]][['par']] <- m[[g]][['parSpec']] 58 | } 59 | if (is.empty(m[[g]][['fixed']])) 60 | { 61 | if (!is.empty(m[[g]][['par']])) 62 | { 63 | m[[g]][['fixed']] <- m[[g]][['par']]==0 64 | } else if (!is.empty(m[[g]][['parSpec']])) 65 | { 66 | m[[g]][['fixed']] <- m[[g]][['parSpec']]==0 67 | } 68 | } 69 | if (!is.empty(m[[g]][['stdComp']])) 70 | { 71 | m[[g]][['std']] <- m[[g]][['stdComp']] 72 | } 73 | if (is.empty(m[[g]][['est']])) m[[g]] <- list() 74 | } 75 | } 76 | 77 | return(m) 78 | } 79 | 80 | is.empty <- function(x) is.null(x) || any(dim(x)==0) 81 | 82 | ### SINGLE GROUP MODEL ### 83 | 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) 84 | { 85 | # 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): 86 | 87 | # Or a list of such lists for each group. 88 | # Check input, replace matrices with list: 89 | mats <- c("LY","PS","BE","TE","TY","AL","LX","PH","GA","TD","TX","KA") 90 | for (m in mats) 91 | { 92 | if (!do.call(missing,list(m))) 93 | { 94 | assign(m,fixMatrix(get(m))) 95 | } else { 96 | assign(m,list()) 97 | } 98 | } 99 | 100 | ### NAMES ### 101 | # If names missing, set default:: 102 | if (missing(manNamesEndo)) 103 | { 104 | if (length(LY)>0 && !is.empty(LY[[1]]$est)) 105 | { 106 | if (!is.null(rownames(LY[[1]]$est)) && !modelLabels) 107 | { 108 | manNamesEndo <- rownames(LY[[1]]$est) 109 | } else manNamesEndo <- paste0("y[",seq_len(nrow(LY[[1]]$est)),"]") 110 | } else if (length(TE)>0 && !is.empty(TE[[1]]$est)) 111 | { 112 | if (!is.null(rownames(TE[[1]]$est)) && !modelLabels) 113 | { 114 | manNamesEndo <- rownames(TE[[1]]$est) 115 | } else manNamesEndo <- paste0("y[",seq_len(nrow(TE[[1]]$est)),"]") 116 | } else if (length(TY)>0 && !is.empty(TY[[1]]$est)) 117 | { 118 | manNamesEndo <- paste0("y[",seq_along(TY[[1]]$est),"]") 119 | } else manNamesEndo <- character(0) 120 | } 121 | 122 | if (missing(latNamesEndo)) 123 | { 124 | if (length(LY)>0 && !is.empty(LY[[1]]$est)) 125 | { 126 | if (!is.null(colnames(LY[[1]]$est)) && !modelLabels) 127 | { 128 | latNamesEndo <- colnames(LY[[1]]$est) 129 | } else latNamesEndo <- paste0("eta[",1:ncol(LY[[1]]$est),"]") 130 | } else if (length(PS)>0 && !is.empty(PS[[1]]$est)) 131 | { 132 | if (!is.null(colnames(PS[[1]]$est)) && !modelLabels) 133 | { 134 | latNamesEndo <- colnames(PS[[1]]$est) 135 | } else latNamesEndo <- paste0("eta[",1:ncol(PS[[1]]$est),"]") 136 | } else if (length(BE)>0 && !is.empty(BE[[1]]$est)) 137 | { 138 | if (!is.null(colnames(BE[[1]]$est)) && !modelLabels) 139 | { 140 | latNamesEndo <- colnames(BE[[1]]$est) 141 | } else latNamesEndo <- paste0("eta[",1:ncol(BE[[1]]$est),"]") 142 | } else if (length(AL)>0 && !is.empty(AL[[1]]$est)) 143 | { 144 | latNamesEndo <- paste0("eta[",seq_along(AL[[1]]$est),"]") 145 | } else latNamesEndo <- character(0) 146 | } 147 | 148 | 149 | # If names missing, set default:: 150 | if (missing(manNamesExo)) 151 | { 152 | if (length(LX)>0 && !is.empty(LX[[1]]$est)) 153 | { 154 | if (!is.null(rownames(LX[[1]]$est)) && !modelLabels) 155 | { 156 | manNamesExo <- rownames(LX[[1]]$est) 157 | } else manNamesExo <- paste0("x[",seq_len(nrow(LX[[1]]$est)),"]") 158 | } else if (length(TD)>0 && !is.empty(TD[[1]]$est)) 159 | { 160 | if (!is.null(rownames(TD[[1]]$est)) && !modelLabels) 161 | { 162 | manNamesExo <- rownames(TD[[1]]$est) 163 | } else manNamesExo <- paste0("x[",seq_len(nrow(TD[[1]]$est)),"]") 164 | } else if (length(TX)>0 && !is.empty(TX[[1]]$est)) 165 | { 166 | manNamesExo <- paste0("x[",seq_along(TX[[1]]$est),"]") 167 | } else manNamesExo <- character(0) 168 | } 169 | 170 | if (missing(latNamesExo)) 171 | { 172 | if (length(LX)>0 && !is.empty(LX[[1]]$est)) 173 | { 174 | if (!is.null(colnames(LX[[1]]$est)) && !modelLabels) 175 | { 176 | latNamesExo <- colnames(LX[[1]]$est) 177 | } else latNamesExo <- paste0("xi[",1:ncol(LX[[1]]$est),"]") 178 | } else if (length(PH)>0 && !is.empty(PH[[1]]$est)) 179 | { 180 | if (!is.null(colnames(PH[[1]]$est)) && !modelLabels) 181 | { 182 | latNamesExo <- colnames(PH[[1]]$est) 183 | } else latNamesExo <- paste0("xi[",1:ncol(PH[[1]]$est),"]") 184 | } else if (length(GA)>0 && !is.empty(GA[[1]]$est)) 185 | { 186 | if (!is.null(colnames(GA[[1]]$est)) && !modelLabels) 187 | { 188 | latNamesExo <- colnames(GA[[1]]$est) 189 | } else latNamesExo <- paste0("xi[",1:ncol(GA[[1]]$est),"]") 190 | } else if (length(KA)>0 && !is.empty(KA[[1]]$est)) 191 | { 192 | latNamesExo <- paste0("xi[",seq_along(KA[[1]]$est),"]") 193 | } else latNamesExo <- character(0) 194 | } 195 | 196 | # Check for duplicate names: 197 | if (!reduce) 198 | { 199 | redFun <- function(x,y,app) 200 | { 201 | x[x%in%y] <- paste0(x[x%in%y],app) 202 | return(x) 203 | } 204 | latNamesEndo <- redFun(latNamesEndo,c(latNamesExo,manNamesExo,manNamesEndo),"_Len") 205 | latNamesExo <- redFun(latNamesExo,c(latNamesEndo,manNamesEndo,manNamesExo),"_Lex") 206 | manNamesEndo <- redFun(manNamesEndo,c(manNamesExo,latNamesEndo,latNamesExo),"_Men") 207 | manNamesExo <- redFun(manNamesExo,c(manNamesEndo,latNamesEndo,latNamesExo),"_Mex") 208 | 209 | } 210 | 211 | 212 | 213 | Len <- sapply(mats,function(x)length(get(x))) 214 | Len <- Len[Len>0] 215 | if (length(unique(Len))>1) stop("Number of groups are not equal across all given LISREL matrices.") 216 | Ng <- max(Len) 217 | 218 | Parss <- list() 219 | dumPars <- data.frame( 220 | label = character(0), 221 | lhs = character(0), 222 | edge = character(0), 223 | rhs = character(0), 224 | est = numeric(0), 225 | std = numeric(0), 226 | group = character(0), 227 | fixed = logical(0), 228 | par = numeric(0), 229 | stringsAsFactors=FALSE) 230 | 231 | if (missing(ImpCovs)) 232 | { 233 | modCovs <- list() 234 | } 235 | 236 | for (g in 1:Ng) 237 | { 238 | # Compute model implied covariance matrix and standardized matrices: 239 | # M is matrix list: 240 | M <- list() 241 | 242 | # Exogenous: 243 | if (length(LX)>0 && !is.empty(LX[[g]]$est)) 244 | { 245 | M$LX <- LX[[g]]$est 246 | } else { 247 | M$LX <- matrix(,0,0) 248 | } 249 | 250 | if (length(PH)>0 && !is.empty(PH[[g]]$est)) 251 | { 252 | M$PH <- PH[[g]]$est 253 | } else { 254 | M$PH <- diag(1,ncol(M$LX),ncol(M$LX)) 255 | } 256 | 257 | if (length(TD)>0 && !is.empty(TD[[g]]$est)) 258 | { 259 | M$TD <- TD[[g]]$est 260 | } else { 261 | M$TD <- matrix(0,nrow(M$LX),nrow(M$LX)) 262 | } 263 | 264 | # Endogenous: 265 | if (length(LY)>0 && !is.empty(LY[[g]]$est)) 266 | { 267 | M$LY <- LY[[g]]$est 268 | } else { 269 | M$LY <- matrix(,0,0) 270 | } 271 | 272 | if (length(PS)>0 && !is.empty(PS[[g]]$est)) 273 | { 274 | M$PS <- PS[[g]]$est 275 | } else { 276 | M$PS <- diag(1,ncol(M$LY),ncol(M$LY)) 277 | } 278 | 279 | if (length(TE)>0 && !is.empty(TE[[g]]$est)) 280 | { 281 | M$TE <- TE[[g]]$est 282 | } else { 283 | M$TE <- matrix(0,nrow(M$LY),nrow(M$LY)) 284 | } 285 | 286 | if (length(BE)>0 && !is.empty(BE[[g]]$est)) 287 | { 288 | M$BE <- BE[[g]]$est 289 | } else { 290 | M$BE <- matrix(0,ncol(M$LY),ncol(M$LY)) 291 | } 292 | 293 | if (length(GA)>0 && !is.empty(GA[[g]]$est)) 294 | { 295 | M$GA <- GA[[g]]$est 296 | } else { 297 | M$GA <- matrix(0,ncol(M$LY),ncol(M$LX)) 298 | } 299 | 300 | ImBinv <- InvEmp(diag(1,nrow(M$BE),ncol(M$BE)) - M$BE) 301 | 302 | # Implied covariances: 303 | XX <- with(M, LX %*% PH %*% t(LX) + TD) 304 | YY <- with(M, LY %*% ( ImBinv %*% (GA %*% PH %*% t(GA) + PS) %*% t(ImBinv)) %*% t(LY) + TE) 305 | XY <- with(M, LX %*% PH %*% t(GA) %*% t(ImBinv) %*% t(LY)) 306 | 307 | if (missing(ImpCovs)) 308 | { 309 | modCovs[[g]] <- rbind(cbind(YY,t(XY)), 310 | cbind(XY,XX)) 311 | rownames(modCovs[[g]]) <- colnames(modCovs[[g]]) <- c(manNamesEndo,manNamesExo) 312 | } 313 | 314 | ## Standardize matrices 315 | # Diagonal matrices: 316 | EE <- with(M, ( ImBinv %*% (GA %*% PH %*% t(GA) + PS) %*% t(ImBinv)) ) 317 | 318 | M$De <- diag(sqrt(diag(EE)),nrow(EE),ncol(EE)) 319 | KK <- with(M, ( PH ) ) 320 | M$Dk <- diag(sqrt(diag(KK)),nrow(KK),ncol(KK)) 321 | M$Dx <- diag(sqrt(diag(XX)),nrow(XX),ncol(XX)) 322 | M$Dy <- diag(sqrt(diag(YY)),nrow(YY),ncol(YY)) 323 | # Inverses 324 | M$Dki <- InvEmp(M$Dk) 325 | M$Dei <- InvEmp(M$De) 326 | M$Dxi <- InvEmp(M$Dx) 327 | M$Dyi <- InvEmp(M$Dy) 328 | 329 | ## Standardize structural part: 330 | Mstd <- M 331 | # Exo: 332 | Mstd$LX <- M$LX %*% M$Dk 333 | Mstd$PH <- M$Dki %*% M$PH %*% M$Dki 334 | # Endo: 335 | Mstd$LY <- M$LY %*% M$De 336 | Mstd$PS <- M$Dei %*% M$PS %*% M$Dei 337 | Mstd$BE <- M$Dei %*% M$BE %*% M$De 338 | Mstd$GA <- M$Dei %*% M$GA %*% M$Dk 339 | 340 | ## Standardize measurment part: 341 | Mstd$LY <- M$Dyi %*% Mstd$LY 342 | Mstd$LX <- M$Dxi %*% Mstd$LX 343 | Mstd$TE <- M$Dyi %*% Mstd$TE %*% M$Dyi 344 | Mstd$TD <- M$Dxi %*% Mstd$TD %*% M$Dxi 345 | 346 | # Store matrices: 347 | if (length(LY) > 0 && !is.empty(LY[[g]]$est) && is.empty(LY[[g]]$std)) LY[[g]]$std <- Mstd$LY 348 | if (length(LX) > 0 && !is.empty(LX[[g]]$est) && is.empty(LX[[g]]$std)) LX[[g]]$std <- Mstd$LX 349 | if (length(TE) > 0 && !is.empty(TE[[g]]$est) && is.empty(TE[[g]]$std)) TE[[g]]$std <- Mstd$TE 350 | if (length(TD) > 0 && !is.empty(TD[[g]]$est) && is.empty(TD[[g]]$std)) TD[[g]]$std <- Mstd$TD 351 | if (length(PH) > 0 && !is.empty(PH[[g]]$est) && is.empty(PH[[g]]$std)) PH[[g]]$std <- Mstd$PH 352 | if (length(PS) > 0 && !is.empty(PS[[g]]$est) && is.empty(PS[[g]]$std)) PS[[g]]$std <- Mstd$PS 353 | if (length(GA) > 0 && !is.empty(GA[[g]]$est) && is.empty(GA[[g]]$std)) GA[[g]]$std <- Mstd$GA 354 | if (length(BE) > 0 && !is.empty(BE[[g]]$est) && is.empty(BE[[g]]$std)) BE[[g]]$std <- Mstd$BE 355 | 356 | 357 | # Extract matrices: 358 | if (length(LY)>0) LYPars <- modMat2Pars(LY[[g]],"->","lambda",symmetric=FALSE,vec=FALSE,latNamesEndo,manNamesEndo,group=paste("Group",g),exprsup="^{(y)}") else LYPars <- dumPars 359 | if (length(TE)>0) TEPars <- modMat2Pars(TE[[g]],"<->","theta",symmetric=TRUE,vec=FALSE,manNamesEndo,manNamesEndo,group=paste("Group",g),exprsup="^{(epsilon)}") else TEPars <- dumPars 360 | if (length(PS)>0) PSPars <- modMat2Pars(PS[[g]],"<->","psi",symmetric=TRUE,vec=FALSE,latNamesEndo,latNamesEndo,group=paste("Group",g),exprsup="") else PSPars <- dumPars 361 | if (length(BE)>0) BEPars <- modMat2Pars(BE[[g]],"->","beta",symmetric=FALSE,vec=FALSE,latNamesEndo,latNamesEndo,group=paste("Group",g),exprsup="") else BEPars <- dumPars 362 | if (length(LX)>0) LXPars <- modMat2Pars(LX[[g]],"->","lambda",symmetric=FALSE,vec=FALSE,latNamesExo,manNamesExo,group=paste("Group",g),exprsup="^{(x)}") else LXPars <- dumPars 363 | if (length(TD)>0) TDPars <- modMat2Pars(TD[[g]],"<->","theta",symmetric=TRUE,vec=FALSE,manNamesExo,manNamesExo,group=paste("Group",g),exprsup="^{(delta)}") else TDPars <- dumPars 364 | if (length(PH)>0) PHPars <- modMat2Pars(PH[[g]],"<->","phi",symmetric=TRUE,vec=FALSE,latNamesExo,latNamesExo,group=paste("Group",g),exprsup="") else PHPars <- dumPars 365 | if (length(GA)>0) GAPars <- modMat2Pars(GA[[g]],"->","gamma",symmetric=FALSE,vec=FALSE,latNamesExo,latNamesEndo,group=paste("Group",g),exprsup="") else GAPars <- dumPars 366 | if (length(TY)>0) TYPars <- modMat2Pars(TY[[g]],"int","tau",symmetric=FALSE,vec=TRUE,"",manNamesEndo,group=paste("Group",g),exprsup="^{(y)}") else TYPars <- dumPars 367 | if (length(TX)>0) TXPars <- modMat2Pars(TX[[g]],"int","tau",symmetric=FALSE,vec=TRUE,"",manNamesExo,group=paste("Group",g),exprsup="^{(x)}") else TXPars <- dumPars 368 | if (length(AL)>0) ALPars <- modMat2Pars(AL[[g]],"int","alpha",symmetric=FALSE,vec=TRUE,"",latNamesEndo,group=paste("Group",g),exprsup="") else ALPars <- dumPars 369 | if (length(KA)>0) KAPars <- modMat2Pars(KA[[g]],"int","kappa",symmetric=FALSE,vec=TRUE,"",latNamesExo,group=paste("Group",g),exprsup="") else KAPars <- dumPars 370 | 371 | # Combine ParsS: 372 | Parss[[g]] <- rbind(LYPars,TEPars,PSPars,BEPars,LXPars,TDPars,PHPars,GAPars,TYPars,TXPars,ALPars,KAPars) 373 | 374 | # Remove zeroes: 375 | Parss[[g]] <- Parss[[g]][Parss[[g]]$est!=0,] 376 | 377 | } 378 | 379 | Pars <- do.call(rbind,Parss) 380 | 381 | # Variable dataframe: 382 | Vars <- data.frame( 383 | name = c(manNamesEndo,manNamesExo,latNamesEndo,latNamesExo), 384 | manifest = c(manNamesEndo,manNamesExo,latNamesEndo,latNamesExo)%in%c(manNamesEndo,manNamesExo), 385 | exogenous = rep(NA,length(c(manNamesEndo,manNamesExo,latNamesEndo,latNamesExo))), 386 | stringsAsFactors=FALSE) 387 | 388 | # Remove duplicates plus factor loadings betwen mans and lats of same name: 389 | Vars <- Vars[!duplicated(Vars$name),] 390 | Pars <- Pars[!(Pars$lhs==Pars$rhs&Pars$edge!="<->"),] 391 | 392 | if (length(unique(Pars$group)) == 1) Pars$group <- '' 393 | 394 | # Set exogenous: 395 | if (missing(setExo)) 396 | { 397 | setExo <- !(length(TD)>0 & length(LX)>0 & length(PH)>0 & length(GA)>0) 398 | } 399 | 400 | if (setExo) 401 | { 402 | Vars$exogenous <- c(manNamesEndo,manNamesExo,latNamesEndo,latNamesExo)%in%c(manNamesExo,latNamesExo) 403 | } 404 | 405 | semModel <- new("semPlotModel") 406 | semModel@Pars <- Pars 407 | semModel@Vars <- Vars 408 | semModel@Original <- list() 409 | 410 | if (!missing(ObsCovs)) 411 | { 412 | semModel@ObsCovs <- list(ObsCovs) 413 | } else { 414 | semModel@ObsCovs <- list() 415 | } 416 | 417 | if (!missing(ImpCovs)) 418 | { 419 | semModel@ImpCovs <- list(ImpCovs) 420 | } else { 421 | semModel@ImpCovs <- modCovs 422 | } 423 | 424 | semModel@Computed <- length(semModel@ImpCovs) > 0 425 | 426 | return(semModel) 427 | } 428 | 429 | 430 | -------------------------------------------------------------------------------- /R/lists.R: -------------------------------------------------------------------------------- 1 | 2 | semPlotModel.list <- function(object,...) 3 | { 4 | if ("mplus.model"%in%class(object)) return(semPlotModel.mplus.model(object,...)) 5 | 6 | mod <- try(semPlotModel_lavaanModel(object,...),silent=TRUE) 7 | if (!"try-error"%in%class(mod)) return(mod) 8 | 9 | isModel <- sapply(object,function(x)"semPlotModel"%in%class(x)) 10 | object[!isModel] <- lapply(object[!isModel],semPlotModel) 11 | if (length(object)>1) 12 | { 13 | Res <- object[[1]] 14 | for (i in 2:length(object)) Res <- Res + object[[i]] 15 | return(Res) 16 | } else return(object) 17 | } 18 | -------------------------------------------------------------------------------- /R/loadings.R: -------------------------------------------------------------------------------- 1 | # semPaths.loadings <- function(object,...) 2 | # { 3 | # invisible(semPaths(semPlotModel(object),...)) 4 | # } 5 | # 6 | 7 | ### SINGLE GROUP MODEL ### 8 | semPlotModel.loadings <- function(object, ...) 9 | { 10 | 11 | # Check if object is of class "sem": 12 | if (!"loadings"%in%class(object)) stop("Input must be a 'factanal' object") 13 | 14 | 15 | manNames <- rownames(object) 16 | latNames <- colnames(object) 17 | 18 | # Define Pars: 19 | Pars <- data.frame( 20 | label = "", 21 | lhs = rep(latNames,each=length(manNames)), 22 | edge = "--", 23 | rhs = rep(manNames,times=length(latNames)), 24 | est = c(object), 25 | std = c(object), 26 | group = "", 27 | fixed = FALSE, 28 | par = 1:length(object), 29 | stringsAsFactors=FALSE) 30 | 31 | 32 | 33 | # Variable dataframe: 34 | Vars <- data.frame( 35 | name = c(manNames[order(apply(abs(object),1,which.max))],latNames), 36 | manifest = c(rep(TRUE,nrow(object)),rep(FALSE,ncol(object))), 37 | exogenous = NA, 38 | stringsAsFactors=FALSE) 39 | 40 | semModel <- new("semPlotModel") 41 | semModel@Pars <- Pars 42 | semModel@Vars <- Vars 43 | semModel@Computed <- FALSE 44 | semModel@Original <- list(object) 45 | semModel@ObsCovs <- list() 46 | semModel@ImpCovs <- list() 47 | 48 | return(semModel) 49 | } 50 | 51 | 52 | -------------------------------------------------------------------------------- /R/mappingfuns.R: -------------------------------------------------------------------------------- 1 | # Map user space to inches space: 2 | usr2inX <- function(x) 3 | { 4 | usr <- c(-1,1,-1,1) 5 | pin <- par("din") 6 | (x-usr[1])/(usr[2]-usr[1]) * pin[1] 7 | } 8 | 9 | usr2inY <- function(x) 10 | { 11 | usr <- c(-1,1,-1,1) 12 | pin <- par("din") 13 | (x-usr[3])/(usr[4]-usr[3]) * pin[2] 14 | } 15 | 16 | # Same but about origin (for atan2): 17 | usr2inX2 <- function(x) 18 | { 19 | usr <- c(-1,1,-1,1) 20 | pin <- par("din") 21 | x/(usr[2]-usr[1]) * pin[1] 22 | } 23 | 24 | usr2inY2 <- function(x) 25 | { 26 | usr <- c(-1,1,-1,1) 27 | pin <- par("din") 28 | x/(usr[4]-usr[3]) * pin[2] 29 | } 30 | atan2usr2in <- function(x,y) atan2(usr2inX2(x),usr2inY2(y))%%(2*pi) 31 | 32 | # Map inches space to user space: 33 | in2usrX <- function(x) 34 | { 35 | usr <- c(-1,1,-1,1) 36 | pin <- par("din") 37 | usr[1] + x/pin[1] * (usr[2] - usr[1]) 38 | } 39 | 40 | in2usrY <- function(x) 41 | { 42 | usr <- c(-1,1,-1,1) 43 | pin <- par("din") 44 | usr[3] + x/pin[2] * (usr[4] - usr[3]) 45 | } -------------------------------------------------------------------------------- /R/modelMatrices.R: -------------------------------------------------------------------------------- 1 | # Function to extract parameters into model matrices: 2 | # Object is semPlotModel or can be created: 3 | 4 | # # Inner functions: 5 | # getRAMmodel <- function(object) 6 | # { 7 | # 8 | # # Parameters: 9 | # Nvar <- nrow(object@Vars) 10 | # Nman <- sum(object@Vars$manifest) 11 | # Names <- object@Vars$name 12 | # 13 | # # Empty matrices: 14 | # A <- S <- matrix(0,Nvar,Nvar) 15 | # F <- cbind(diag(1,Nman),matrix(0,Nman,Nvar-Nman)) 16 | # F[,order(object@Vars$manifest,decreasing=TRUE)] <- F 17 | # rownames(A) <- colnames(A) <- rownames(S) <- colnames(S) <- colnames(F) <- Names 18 | # rownames(F) <- Names[object@Vars$manifest] 19 | # 20 | # # Fill matrices: 21 | # for (i in seq_len(nrow(object@Pars))) 22 | # { 23 | # if (object@Pars$edge[i]=="<->") 24 | # { 25 | # S[which(Names==object@Pars$lhs[i])[1],which(Names==object@Pars$rhs[i])[1]] <- 26 | # S[which(Names==object@Pars$rhs[i])[1],which(Names==object@Pars$lhs[i])[1]] <- object@Pars$est[i] 27 | # } 28 | # if (object@Pars$edge[i]%in%c("->","~>")) 29 | # { 30 | # A[which(Names==object@Pars$rhs[i])[1],which(Names==object@Pars$lhs[i])[1]] <- object@Pars$est[i] 31 | # } 32 | # } 33 | # 34 | # Res <- list(A=A,S=S,F=F) 35 | # class(Res) <- "RAM" 36 | # return(Res) 37 | # } 38 | 39 | modelMatrices <- function(object,model="ram", endoOnly = FALSE) 40 | { 41 | # Check if input is combination of models: 42 | call <- paste(deparse(substitute(object)), collapse = "") 43 | if (grepl("\\+",call)) 44 | { 45 | args <- unlist(strsplit(call,split="\\+")) 46 | obs <- lapply(args,function(x)semPlotModel(eval(parse(text=x)))) 47 | object <- obs[[1]] 48 | for (i in 2:length(obs)) object <- object + obs[[i]] 49 | } 50 | 51 | if (!"semPlotModel"%in%class(object)) object <- semPlotModel(object) 52 | stopifnot("semPlotModel"%in%class(object)) 53 | 54 | ### SETUP ### 55 | Model <- list() 56 | class(Model) <- "semMatrixModel" 57 | 58 | # Define exogeneity: 59 | if (endoOnly) 60 | { 61 | object@Vars$exogenous <- FALSE 62 | } else { 63 | if (any(is.na(object@Vars$exogenous))) 64 | { 65 | object <- defExo(object) 66 | } 67 | } 68 | 69 | 70 | ### RAM MODEL ### 71 | if (grepl("ram",model,ignore.case=TRUE)) 72 | { 73 | # Extract names: 74 | man <- object@Vars$name[object@Vars$manifest] 75 | lat <- object@Vars$name[!object@Vars$manifest] 76 | all <- object@Vars$name 77 | 78 | # Extract matrices: 79 | Model[['A']] <- Pars2Matrix(object@Pars, c("->","~>"), all, all) 80 | Model[['S']] <- Pars2Matrix(object@Pars, "<->", all, all) 81 | Model[['F']] <- FilterMatrix(object@Pars, object@Vars) 82 | 83 | return(Model) 84 | } 85 | 86 | 87 | ### LISREL MODEL ###: 88 | if (grepl("lis",model,ignore.case=TRUE)) 89 | { 90 | # Extract names: 91 | manExo <- object@Vars$name[object@Vars$manifest & object@Vars$exogenous] 92 | manEndo <- object@Vars$name[object@Vars$manifest & !object@Vars$exogenous] 93 | latExo <- object@Vars$name[!object@Vars$manifest & object@Vars$exogenous] 94 | latEndo <- object@Vars$name[!object@Vars$manifest & !object@Vars$exogenous] 95 | 96 | # If any manifest var is used in regression, create dummy latents: 97 | if (any(object@Pars$lhs[object@Pars$edge%in%c("->","~>")] %in% c(manExo,manEndo))) 98 | { 99 | message("Latent dummy variables added to include manifest regressions") 100 | # Identify variables: 101 | manRegs <- c(manExo,manEndo)[c(manExo,manEndo)%in%object@Pars$lhs[object@Pars$edge%in%c("->","~>")]] 102 | newVars <- object@Vars[object@Vars$name %in% manRegs,] 103 | newVars$manifest <- FALSE 104 | newVars$name <- paste0(newVars$name,"@L@") 105 | object@Vars <- rbind(object@Vars,newVars) 106 | 107 | # Change regressions to latents: 108 | 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@") 109 | 110 | manVarResids <- which(object@Pars$lhs %in% manRegs & object@Pars$rhs %in% manRegs & object@Pars$edge=="<->") 111 | 112 | object@Pars$lhs[manVarResids] <- paste0(object@Pars$lhs[manVarResids],"@L@") 113 | object@Pars$rhs[manVarResids] <- paste0(object@Pars$rhs[manVarResids],"@L@") 114 | 115 | 116 | # Add factor loadings: 117 | for (g in unique(object@Pars$group)) 118 | { 119 | parLocs <- nrow(object@Pars)+seq_along(manRegs) 120 | object@Pars[parLocs,"lhs"] <- paste0(manRegs,"@L@") 121 | object@Pars[parLocs,"rhs"] <- manRegs 122 | object@Pars[parLocs,"label"] <- "" 123 | object@Pars[parLocs,"est"] <- 1 124 | object@Pars[parLocs,"std"] <- NA 125 | object@Pars[parLocs,"group"] <- g 126 | object@Pars[parLocs,"fixed"] <- TRUE 127 | object@Pars[parLocs,"par"] <- 0 128 | } 129 | 130 | # Extract names: 131 | manExo <- object@Vars$name[object@Vars$manifest & object@Vars$exogenous] 132 | manEndo <- object@Vars$name[object@Vars$manifest & !object@Vars$exogenous] 133 | latExo <- object@Vars$name[!object@Vars$manifest & object@Vars$exogenous] 134 | latEndo <- object@Vars$name[!object@Vars$manifest & !object@Vars$exogenous] 135 | } 136 | 137 | # Extract matrices: 138 | Model[['LY']] <- Pars2Matrix(object@Pars, c("->","~>"), manEndo, latEndo) 139 | Model[['TE']] <- Pars2Matrix(object@Pars, "<->", manEndo, manEndo) 140 | Model[['PS']] <- Pars2Matrix(object@Pars, "<->", latEndo, latEndo) 141 | Model[['BE']] <- Pars2Matrix(object@Pars, c("->","~>"), latEndo, latEndo) 142 | 143 | Model[['LX']] <- Pars2Matrix(object@Pars, c("->","~>"), manExo, latExo) 144 | Model[['TD']] <- Pars2Matrix(object@Pars, "<->", manExo, manExo) 145 | Model[['PH']] <- Pars2Matrix(object@Pars, "<->", latExo, latExo) 146 | Model[['GA']] <- Pars2Matrix(object@Pars, c("->","~>"), latEndo, latExo) 147 | 148 | Model[['TY']] <- Pars2Matrix(object@Pars, "int", manEndo, "1") 149 | Model[['TX']] <- Pars2Matrix(object@Pars, "int", manExo, "1") 150 | Model[['AL']] <- Pars2Matrix(object@Pars, "int", latEndo, "1") 151 | Model[['KA']] <- Pars2Matrix(object@Pars, "int", latExo, "1") 152 | 153 | return(Model) 154 | } 155 | 156 | 157 | 158 | ### Mplus MODEL ###: 159 | if (grepl("mplus",model,ignore.case=TRUE)) 160 | { 161 | # Extract names (exo only if manifest has outgoing cons. error if in and outgoing): 162 | man <- object@Vars$name[object@Vars$manifest] 163 | lat <- object@Vars$name[!object@Vars$manifest] 164 | 165 | # Control input: 166 | 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.") 167 | if (any(object@Pars$rhs %in% man & object@Pars$lhs %in% lat & object@Pars$edge == "~>")) 168 | { 169 | warning("Can not place regression (ON) from latent to manifest in a model matrix. Interpreted as factor loading (BY).") 170 | object@Pars$edge[object@Pars$rhs %in% man & object@Pars$lhs %in% lat & object@Pars$edge == "~>"] <- "->" 171 | } 172 | 173 | trueExo <- sapply(man, function(m) any((object@Pars$lhs==m & object@Pars$edge %in% c("->","~>")) & !(object@Pars$rhs==m & object@Pars$edge %in% c("->","~>")))) 174 | manEndo <- man[!trueExo] 175 | manExo <- man[trueExo] 176 | 177 | 178 | ## Extract matrices: 179 | # BY matrices: 180 | Model[['Nu']] <- Pars2Matrix(object@Pars, "int", manEndo, "1") 181 | Model[['Lambda']] <- Pars2Matrix(object@Pars, c("->","~>"), manEndo, lat) 182 | Model[['Theta']] <- Pars2Matrix(object@Pars, "<->", manEndo, manEndo) 183 | 184 | # ON matrices: 185 | Model[['Kappa']] <- Pars2Matrix(object@Pars, c("->","~>"), manEndo, manExo) 186 | Model[['Alpha']] <- Pars2Matrix(object@Pars, "int", lat, "1") 187 | Model[['Beta']] <- Pars2Matrix(object@Pars, c("->","~>"), lat, lat) 188 | Model[['Gamma']] <- Pars2Matrix(object@Pars, c("->","~>"), lat, manExo) 189 | Model[['Psi']] <- Pars2Matrix(object@Pars, "<->", lat, lat) 190 | 191 | return(Model) 192 | } 193 | 194 | 195 | else stop(paste("Model",model,"is not supported.")) 196 | 197 | } -------------------------------------------------------------------------------- /R/mplus.R: -------------------------------------------------------------------------------- 1 | # 2 | # # object <- readModels(file.choose()) 3 | # semPaths.mplus.model <- function(object,...) 4 | # { 5 | # invisible(semPaths(semPlotModel(object),...)) 6 | # } 7 | 8 | readModels <- NULL 9 | 10 | semPlotModel.mplus.model <- function (object,mplusStd=c("std", "stdy", "stdyx"),...) 11 | { 12 | mplusStd <- match.arg(mplusStd) 13 | 14 | # Check for mplusAutomation: 15 | if (!requireNamespace("MplusAutomation")) stop("'MplusAutomation' package must be installed to read Mplus output.") 16 | 17 | 18 | addInteractions <- FALSE 19 | if (is.character(object)) 20 | { 21 | modfile <- object 22 | object <- MplusAutomation::readModels(object) 23 | 24 | Lambda <- NULL 25 | Beta <- NULL 26 | Psi <- NULL 27 | Theta <- NULL 28 | 29 | mod <- readLines(modfile) 30 | # Find XWITH: 31 | xs <- grep("XWITH",mod) 32 | if (length(xs)>0) 33 | { 34 | # Split: 35 | spl <- strsplit(mod[xs],split="\\|") 36 | # Find vars that interact: 37 | vars <- lapply(spl,function(x)strsplit(x[2],split="XWITH")[[1]]) 38 | # Extract Vars 39 | newvars <- sapply(spl,'[',1) 40 | # sanitize: 41 | newvars <- gsub("\\W","",newvars) 42 | vars <- lapply(vars,gsub,pattern="\\W",replacement="") 43 | 44 | addInteractions <- TRUE 45 | } 46 | 47 | } else warning("Interactions are ommited. Use semPlotModel.mplus.model on the path to mplus output file for semPlot to attempt to find assigned interactions.") 48 | 49 | if (length(object$parameters)==0) stop("No parameters detected in mplus output.") 50 | 51 | parsUS <- object$parameters$unstandardized 52 | if (is.null(parsUS$Group)) parsUS$Group <- "" 53 | if (is.null(parsUS$BetweenWithin)) parsUS$BetweenWithin <- "" 54 | 55 | if (any(grepl("\\|",parsUS$paramHeader))) 56 | { 57 | parsUS$paramHeader <- gsub("\\|", "BY", parsUS$paramHeader) 58 | warning("'|' operator replaced by BY operator.") 59 | } 60 | 61 | if (any(grepl("New.Additional.Parameters",parsUS$paramHeader))) 62 | { 63 | parsUS <- parsUS[!grepl("New.Additional.Parameters",parsUS$paramHeader),] 64 | warning("'New.Additional.Parameters' is not yet supported by semPlot. Parameters will not be shown and unexpected results might occur.") 65 | } 66 | 67 | noPars <- FALSE 68 | # Temporary fix for EFA: 69 | if (is.null(parsUS$est)) 70 | { 71 | if (!is.null(parsUS$average)) 72 | { 73 | parsUS$est <- parsUS$average 74 | parsUS$se <- parsUS$average_se 75 | } else 76 | { 77 | parsUS$est <- 0 78 | parsUS$se <- 0 79 | noPars <- TRUE 80 | } 81 | } 82 | 83 | # Only find fixed if SE is present: 84 | if (!is.null(parsUS$se)){ 85 | fixed <- parsUS$se==0 86 | } else { 87 | fixed <- FALSE 88 | } 89 | 90 | # Define Pars: 91 | Pars <- data.frame( 92 | label = "", 93 | lhs = "", 94 | edge = "--", 95 | rhs = parsUS$param, 96 | est = parsUS$est, 97 | std = NA, 98 | group = parsUS$Group, 99 | fixed = fixed, 100 | par = 0, 101 | BetweenWithin = parsUS$BetweenWithin, 102 | stringsAsFactors=FALSE) 103 | 104 | # This code will check if parameters are equal. Check on as many of these columns as possible: 105 | checkCols <- c("est","se", "posterior_sd" ,"pval","lower_2.5ci","upper_2.5ci" ) 106 | checkCols <- checkCols[checkCols %in% names(parsUS)] 107 | 108 | if (!noPars) 109 | { 110 | parNums <- dlply(cbind(sapply(parsUS[checkCols],function(x)round(as.numeric(x),10)),data.frame(num=1:nrow(parsUS))),checkCols,'[[',"num") 111 | for (i in 1:length(parNums)) Pars$par[parNums[[i]]] <- i 112 | Pars$par[Pars$fixed] <- 0 113 | } else Pars$par <- 1:nrow(Pars) 114 | 115 | # 116 | # c <- 1 117 | # for (i in 1:nrow(Pars)) 118 | # { 119 | # if (!isTRUE(Pars$fixed[i]) & Pars$par[i]==0) 120 | # { 121 | # 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")])))) 122 | # Pars$par[par] <- c 123 | # c <- c+1 124 | # } 125 | # } 126 | 127 | #Standardization 128 | #mplusStd <- modelOpts$mplusStd 129 | #Call args from semPaths() 130 | 131 | # if (!is.null(object$parameters$std.standardized) & 132 | # (grepl("stand",sys.call(which =1)[3])|grepl("std",sys.call(which =1)[3])) & sys.call(3)$mplusStd=="std") 133 | # { 134 | # Pars$std <- object$parameters$std.standardized$est 135 | # warning("Mplus std parameters will be plotted. To change that, use the modelOpts argument and set mplusStd to stdy, or stdyx parameters.") 136 | # }else if (!is.null(object$parameters$stdy.standardized) & sys.call(3)$mplusStd=="stdy"){ 137 | # Pars$std <- object$parameters$stdy.standardized$est 138 | # }else if (!is.null(object$parameters$stdyx.standardized) & sys.call(3)$mplusStd=="stdyx"){ 139 | # Pars$std <- object$parameters$stdyx.standardized$est 140 | # } 141 | 142 | 143 | if (!is.null(object$parameters$std.standardized) && mplusStd == "std") 144 | { 145 | Pars$std <- object$parameters$std.standardized$est 146 | # warning("Mplus std parameters will be plotted. To change that, use the modelOpts argument and set mplusStd to stdy, or stdyx parameters.") 147 | } else if (!is.null(object$parameters$stdy.standardized) && mplusStd == "stdy") 148 | { 149 | Pars$std <- object$parameters$stdy.standardized$est 150 | } else if (!is.null(object$parameters$stdyx.standardized) && mplusStd == "stdyx") 151 | { 152 | Pars$std <- object$parameters$stdyx.standardized$est 153 | } else if (!is.null(object$parameters$standardized)) 154 | { 155 | Pars$std <- object$parameters$standardized$est 156 | } 157 | 158 | Pars$lhs[grepl(".BY$",parsUS$paramHeader)] <- gsub("\\.BY$","",parsUS$paramHeader[grepl(".BY$",parsUS$paramHeader)]) 159 | Pars$edge[grepl(".BY$",parsUS$paramHeader)] <- "->" 160 | 161 | Pars$lhs[grepl(".ON$",parsUS$paramHeader)] <- gsub("\\.ON$","",parsUS$paramHeader[grepl(".ON$",parsUS$paramHeader)]) 162 | Pars$edge[grepl(".ON$",parsUS$paramHeader)] <- "~>" 163 | Pars[grepl(".ON$",parsUS$paramHeader),c("lhs","rhs")] <- Pars[grepl(".ON$",parsUS$paramHeader),c("rhs","lhs")] 164 | 165 | Pars$lhs[grepl(".WITH$",parsUS$paramHeader)] <- gsub("\\.WITH$","",parsUS$paramHeader[grepl(".WITH$",parsUS$paramHeader)]) 166 | Pars$edge[grepl(".WITH$",parsUS$paramHeader)] <- "<->" 167 | 168 | Pars$lhs[grepl("Variances",parsUS$paramHeader)] <- Pars$rhs[grepl("Variances",parsUS$paramHeader)] 169 | Pars$edge[grepl("Variances",parsUS$paramHeader)] <- "<->" 170 | 171 | Pars$edge[grepl("Means|Intercepts",parsUS$paramHeader)] <- "int" 172 | 173 | # Extract threshold model: 174 | Thresh <- Pars[grepl("Thresholds",parsUS$paramHeader),-(3:4)] 175 | Thresh$lhs <- gsub("\\$.*","",Pars$rhs[grepl("Thresholds",parsUS$paramHeader)]) 176 | Thresh$BetweenWithin[Thresh$BetweenWithin == "Between"] <- "Within" 177 | Pars <- Pars[!grepl("Thresholds",parsUS$paramHeader),] 178 | 179 | # Detect latent/manifest: 180 | Latents <- unique(gsub("\\.BY$","",parsUS$paramHeader[grepl(".BY$",parsUS$paramHeader)])) 181 | var <- unique(unlist(Pars[c("lhs","rhs")])) 182 | var <- var[var!=""] 183 | 184 | # Variable dataframe: 185 | Vars <- data.frame( 186 | name = var, 187 | manifest = !var%in%Latents, 188 | exogenous = NA, 189 | stringsAsFactors=FALSE) 190 | 191 | 192 | ### Add interactions and remove dummy variables: 193 | if (addInteractions) 194 | { 195 | Vars <- Vars[!tolower(Vars$name)%in%tolower(newvars),] 196 | 197 | Pars$knot <- 0 198 | k <- 1 199 | for (i in rev(seq_along(newvars))) 200 | { 201 | varlocs <- which(tolower(Pars$lhs)==tolower(newvars[i])|tolower(Pars$rhs)==tolower(newvars[i])) 202 | for (v in seq_along(varlocs)) 203 | { 204 | for (j in 1:length(vars[[i]])) 205 | { 206 | Parsnew <- Pars[varlocs[v],] 207 | Parsnew$lhs[tolower(Parsnew$lhs)==tolower(newvars[i])] <- Vars$name[match(tolower(vars[[i]][j]),tolower(Vars$name))] 208 | Parsnew$rhs[tolower(Parsnew$rhs)==tolower(newvars[i])] <- Vars$name[match(tolower(vars[[i]][j]),tolower(Vars$name))] 209 | if (Parsnew$knot==0) 210 | { 211 | Parsnew$knot <- k 212 | } 213 | Pars <- rbind(Pars,Parsnew) 214 | } 215 | if (any(Pars$knot==k)) k <- k + 1 216 | } 217 | Pars <- Pars[-varlocs,] 218 | } 219 | 220 | } 221 | 222 | 223 | # Abbreviate names with more than 8 characters: 224 | Pars$lhs <- substring(Pars$lhs,1,8) 225 | Pars$rhs <- substring(Pars$rhs,1,8) 226 | Vars$name <- substring(Vars$name,1,8) 227 | Vars <- Vars[!duplicated(Vars),] 228 | 229 | 230 | semModel <- new("semPlotModel") 231 | semModel@Pars <- Pars 232 | semModel@Vars <- Vars 233 | semModel@Computed <- TRUE 234 | semModel@Original <- list(object) 235 | semModel@ObsCovs <- list() 236 | semModel@Thresholds <- Thresh 237 | ImpCovs <- semMatrixAlgebra(semModel, Lambda %*% Imin(Beta, TRUE) %*% Psi %*% t(Imin(Beta, TRUE)) %*% t(Lambda) + Theta,model = "mplus") 238 | if (!is.list(ImpCovs)) ImpCovs <- list(ImpCovs) 239 | semModel@ImpCovs <- ImpCovs 240 | 241 | return(semModel) 242 | } 243 | -------------------------------------------------------------------------------- /R/onyx.R: -------------------------------------------------------------------------------- 1 | 2 | semPlotModel_Onyx <- function(object) 3 | { 4 | # Parse Onyx model: 5 | doc <- xmlParse(object) 6 | 7 | # Get Nodes and Edges: 8 | Nodes <- getNodeSet(doc, "/model/graph/node") 9 | Edges <- getNodeSet(doc, "/model/graph/edge") 10 | Const <- as.logical(sapply(Nodes, function(n) xmlGetAttr(n, "constant"))) 11 | 12 | # Get NodeNames: 13 | NodeNames <- sapply(Nodes, function(n) xmlGetAttr(n, "caption")) 14 | NodeNames[Const] <- "" 15 | 16 | # Get edgelist: 17 | Edgelist <- data.frame( 18 | From = as.numeric(as.character(sapply(Edges, function(n) xmlGetAttr(n, "sourceNodeId")))), 19 | To = as.numeric(as.character(sapply(Edges, function(n) xmlGetAttr(n, "targetNodeId")))), 20 | stringsAsFactors=FALSE) + 1 21 | 22 | # Define Pars: 23 | Pars <- data.frame( 24 | label = sapply(Edges, function(n) xmlGetAttr(n, "parameterName")), 25 | lhs = NodeNames[Edgelist$From], 26 | edge = ifelse(as.logical(sapply(Edges, function(n) xmlGetAttr(n, "doubleHeaded"))),"<->","->"), 27 | rhs = NodeNames[Edgelist$To], 28 | est = as.numeric(as.character(sapply(Edges, function(n) xmlGetAttr(n, "value")))), 29 | std = NA, 30 | group = "", 31 | fixed = as.logical(sapply(Edges, function(n) xmlGetAttr(n, "fixed"))), 32 | par = 0, 33 | stringsAsFactors=FALSE) 34 | 35 | Pars$edge[Pars$lhs==""] <- "int" 36 | Pars$par <- 1:nrow(Pars) 37 | 38 | # Vars: 39 | Vars <- data.frame( 40 | name = NodeNames, 41 | manifest = !as.logical(sapply(Nodes, function(n) xmlGetAttr(n, "latent"))), 42 | exogenous = NA, 43 | stringsAsFactors=FALSE) 44 | 45 | Vars <- Vars[c(which(Vars$manifest),which(!Vars$manifest)),] 46 | 47 | # Return: 48 | semModel <- new("semPlotModel") 49 | semModel@Pars <- Pars 50 | semModel@Vars <- Vars 51 | semModel@Computed <- FALSE 52 | semModel@Original <- list(doc) 53 | semModel@ObsCovs <- list() 54 | semModel@ImpCovs <- list() 55 | # semModel@Thresholds <- Thresh 56 | 57 | return(semModel) 58 | } -------------------------------------------------------------------------------- /R/operators.R: -------------------------------------------------------------------------------- 1 | # Add function: 2 | '+.semPlotModel' <- function(x,y) 3 | { 4 | stopifnot("semPlotModel"%in%class(x)) 5 | stopifnot("semPlotModel"%in%class(y)) 6 | 7 | # Update par in y: 8 | y@Pars$par[y@Pars$par>0] <- max(x@Pars$par) + y@Pars$par[y@Pars$par>0] 9 | 10 | # New model: 11 | semModel <- new("semPlotModel") 12 | semModel@Pars <- rbind(x@Pars,y@Pars) 13 | semModel@Vars <- rbind(x@Vars,y@Vars) 14 | semModel@Vars <- semModel@Vars[!duplicated(semModel@Vars),] 15 | semModel@Thresholds <- rbind(x@Thresholds,y@Thresholds) 16 | semModel@Computed <- x@Computed && y@Computed 17 | semModel@Original <- list(x@Original[[1]],y@Original[[1]]) 18 | semModel@ObsCovs <- c(x@ObsCovs,y@ObsCovs) 19 | semModel@ImpCovs <- c(x@ImpCovs,y@ImpCovs) 20 | 21 | # Return: 22 | return(semModel) 23 | } -------------------------------------------------------------------------------- /R/principal.R: -------------------------------------------------------------------------------- 1 | # semPaths.principal <- function(object,...) 2 | # { 3 | # invisible(semPaths(semPlotModel(object),...)) 4 | # } 5 | # 6 | 7 | 8 | ### SINGLE GROUP MODEL ### 9 | semPlotModel.principal <- function(object, ...) 10 | { 11 | 12 | # Check if object is of class "sem": 13 | if (!"principal"%in%class(object)) stop("Input must be a 'principal' object") 14 | 15 | # Extract model: 16 | mod <- semPlotModel(loadings(object)) 17 | manNames <- mod@Vars$name[mod@Vars$manifest] 18 | 19 | # Fix: 20 | mod@Pars[c("lhs","rhs")] <- mod@Pars[c("rhs","lhs")] 21 | mod@Pars$edge <- "->" 22 | 23 | return(mod) 24 | } 25 | 26 | -------------------------------------------------------------------------------- /R/princomp.R: -------------------------------------------------------------------------------- 1 | # semPaths.princomp <- function(object,...) 2 | # { 3 | # invisible(semPaths(semPlotModel(object),...)) 4 | # } 5 | # 6 | 7 | 8 | ### SINGLE GROUP MODEL ### 9 | semPlotModel.princomp <- function(object, ...) 10 | { 11 | 12 | # Check if object is of class "sem": 13 | if (!"princomp"%in%class(object)) stop("Input must be a 'princomp' object") 14 | 15 | 16 | # Extract model: 17 | mod <- semPlotModel(loadings(object)) 18 | manNames <- mod@Vars$name[mod@Vars$manifest] 19 | 20 | # Fix: 21 | mod@Pars[c("lhs","rhs")] <- mod@Pars[c("rhs","lhs")] 22 | mod@Pars$edge <- "->" 23 | 24 | return(mod) 25 | } 26 | 27 | -------------------------------------------------------------------------------- /R/ramModel.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | ### SINGLE GROUP MODEL ### 4 | ramModel <- function(A,S,F,M,manNames,latNames,Names,ObsCovs,ImpCovs,modelLabels = FALSE) 5 | { 6 | # Check if meanstructure is included: 7 | meanstructure <- !missing(M) 8 | # 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): 9 | 10 | # Or a list of such lists for each group. 11 | # Check input, replace matrices with list: 12 | mats <- c("A","S","F", "M") 13 | for (m in mats) 14 | { 15 | if (!do.call(missing,list(m))) 16 | { 17 | assign(m,fixMatrix(get(m))) 18 | } else { 19 | assign(m,list()) 20 | } 21 | } 22 | 23 | ### Fix matrices: 24 | matList <- list(A,S,F) 25 | 26 | Ng <- max(sapply(matList,length)) 27 | Nvar <- max(sapply(matList,function(x)sapply(x,function(y)ncol(y$est)))) 28 | if (length(F)>0 && !is.null(F[[1]]$est)) 29 | { 30 | Nman <- max(sapply(F,function(y)nrow(y$est))) 31 | } else 32 | { 33 | if (!missing(manNames)) Nman <- length(manNames) else Nman <- Nvar 34 | } 35 | 36 | if (!missing(manNames) & !missing(latNames)) 37 | { 38 | if (Nvar!=length(c(manNames,latNames))) stop("Number of variables in model not equal to given number of names") 39 | } 40 | 41 | if (!missing(manNames)) 42 | { 43 | if (Nman!=length(manNames)) stop("Number of manifest variables in model not equal to given number of names") 44 | } 45 | 46 | # Fix A: 47 | if (length(A)==0) 48 | { 49 | A <- lapply(seq_len(Ng),function(x)list(est=matrix(0,Nvar,Nvar))) 50 | } else if (length(A) < Ng) A <- rep(A,length=Ng) 51 | 52 | # Fix S 53 | if (length(S)==0) 54 | { 55 | S <- lapply(seq_len(Ng),function(x)list(est=matrix(0,Nvar,Nvar))) 56 | } else if (length(S) < Ng) S <- rep(S,length=Ng) 57 | 58 | # Fix F: 59 | if (length(F)==0) 60 | { 61 | F <- lapply(seq_len(Ng),function(x)list(est=cbind(diag(1,Nman,Nman),matrix(0,Nman,Nvar-Nman)))) 62 | } else if (length(F) < Ng) F <- rep(F,length=Ng) 63 | 64 | # Fix M: 65 | if (length(M)==0) 66 | { 67 | M <- lapply(seq_len(Ng),function(x)list(est=rep(0,Nvar))) 68 | } else if (length(M) < Ng) M <- rep(M,length=Ng) 69 | 70 | 71 | ### NAMES ### 72 | # If names missing, set default:: 73 | if (missing(manNames)) 74 | { 75 | if (length(F)>0 && !is.null(F[[1]]$est)) 76 | { 77 | if (!is.null(colnames(F[[1]]$est)) && !modelLabels) 78 | { 79 | manNames <- colnames(F[[1]]$est)[colSums(F[[1]]$est)>0] 80 | } else manNames <- paste0(rep("m",Nman),seq_len(Nman)) 81 | } else manNames <- paste0(rep("m",Nman),seq_len(Nman)) 82 | } 83 | 84 | if (missing(latNames)) 85 | { 86 | if (length(F)>0 && !is.null(F[[1]]$est)) 87 | { 88 | if (!is.null(colnames(F[[1]]$est)) && !modelLabels) 89 | { 90 | latNames <- colnames(F[[1]]$est)[colSums(F[[1]]$est)==0] 91 | } else latNames <- paste0(rep("l",Nvar-Nman),seq_len(Nvar-Nman)) 92 | } else latNames <- paste0(rep("l",Nvar-Nman),seq_len(Nvar-Nman)) 93 | } 94 | 95 | if (missing(Names)) 96 | { 97 | if (length(F)>0 && !is.null(F[[1]]$est)) 98 | { 99 | if (!is.null(colnames(F[[1]]$est)) && !modelLabels) 100 | { 101 | Names <- colnames(F[[1]]$est) 102 | } else Names <- c(manNames,latNames) 103 | } else Names <- c(manNames,latNames) 104 | } 105 | 106 | Parss <- list() 107 | dumPars <- data.frame( 108 | label = character(0), 109 | lhs = character(0), 110 | edge = character(0), 111 | rhs = character(0), 112 | est = numeric(0), 113 | std = numeric(0), 114 | group = character(0), 115 | fixed = logical(0), 116 | par = numeric(0), 117 | stringsAsFactors=FALSE) 118 | 119 | if (missing(ImpCovs)) 120 | { 121 | modCovs <- list() 122 | } 123 | 124 | for (g in 1:Ng) 125 | { 126 | # Compute model implied covariance matrix and standardized matrices: 127 | # M is matrix list: 128 | Mod <- list(A=A[[g]]$est, S=S[[g]]$est, F=F[[g]]$est) 129 | 130 | IminAinv <- InvEmp(diag(1,nrow(Mod$A),ncol(Mod$A)) - Mod$A) 131 | if (missing(ImpCovs)) 132 | { 133 | modCovs[[g]] <- with(Mod, F %*% IminAinv %*% S %*% t(IminAinv) %*% t(F)) 134 | 135 | rownames(modCovs[[g]]) <- colnames(modCovs[[g]]) <- manNames 136 | } 137 | 138 | Mstd <- Mod 139 | ## Standardize matrices 140 | I <- diag(nrow(Mod$S)) 141 | expCov <- IminAinv %*% Mod$S %*% t(IminAinv) 142 | invSDs <- 1/sqrt(diag(expCov)) 143 | diag(I) <- invSDs 144 | # standardize the A, S and M matrices 145 | # A paths are value*sd(from)/sd(to) = I %*% A %*% solve(I) 146 | # S paths are value/(sd(from*sd(to))) = I %*% S %*% I 147 | Mstd$A <- I %*% Mod$A %*% solve(I) 148 | Mstd$S <- I %*% Mod$S %*% I 149 | 150 | # Store matrices: 151 | if (length(A) > 0 && !is.null(A[[g]]$est) && is.null(A[[g]]$std)) A[[g]]$std <- Mstd$A 152 | if (length(S) > 0 && !is.null(S[[g]]$est) && is.null(S[[g]]$std)) S[[g]]$std <- Mstd$S 153 | 154 | # Extract matrices: 155 | if (length(A)>0) APars <- modMat2Pars(A[[g]],"->","A",symmetric=FALSE,vec=FALSE,Names,Names,group=paste("Group",g),exprsup="") else APars <- dumPars 156 | if (length(S)>0) SPars <- modMat2Pars(S[[g]],"<->","S",symmetric=TRUE,vec=FALSE,Names,Names,group=paste("Group",g),exprsup="") else SPars <- dumPars 157 | 158 | if (length(M)>0) MPars <- modMat2Pars(M[[g]],"int","M",symmetric=FALSE,vec=TRUE,"",Names,group=paste("Group",g),exprsup="") else Mpars <- dumPars 159 | 160 | 161 | # Combine ParsS: 162 | Parss[[g]] <- rbind(APars,SPars,MPars) 163 | 164 | # Remove zeroes: 165 | Parss[[g]] <- Parss[[g]][Parss[[g]]$est!=0,] 166 | } 167 | 168 | Pars <- do.call(rbind,Parss) 169 | 170 | # Variable dataframe: 171 | Vars <- data.frame( 172 | name = c(manNames,latNames), 173 | manifest = c(manNames,latNames)%in%manNames, 174 | exogenous = NA, 175 | stringsAsFactors=FALSE) 176 | 177 | # Remove duplicates plus factor loadings betwen mans and lats of same name: 178 | Vars <- Vars[!duplicated(Vars$name),] 179 | Pars <- Pars[!(Pars$lhs==Pars$rhs&Pars$edge!="<->"),] 180 | 181 | semModel <- new("semPlotModel") 182 | semModel@Pars <- Pars 183 | semModel@Vars <- Vars 184 | semModel@Original <- list() 185 | 186 | if (!missing(ObsCovs)) 187 | { 188 | semModel@ObsCovs <- list(ObsCovs) 189 | } else { 190 | semModel@ObsCovs <- list() 191 | } 192 | 193 | if (!missing(ImpCovs)) 194 | { 195 | semModel@ImpCovs <- list(ImpCovs) 196 | } else { 197 | semModel@ImpCovs <- modCovs 198 | } 199 | 200 | semModel@Computed <- length(semModel@ImpCovs) > 0 201 | 202 | return(semModel) 203 | } 204 | 205 | 206 | -------------------------------------------------------------------------------- /R/regsemplot.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | semPlotModel.regsem <- semPlotModel.regsemplot <- function(object,...){ 4 | 5 | ## Save parts of the output in objects 6 | object1 <- object$lav.model@ParTable # parameters 7 | object2 <- object$lav.model@Model@dimNames # variable names 8 | varnames <- unique(c(object1$lhs, object1$rhs)) # all names 9 | mannames <- object2[[1]][1] # manifest variables 10 | names(mannames) <- 'manifest' 11 | 12 | '%!in%' <- function(x,y)!('%in%'(x,y)) 13 | 14 | ## Add the fixed relations to the parameter estimates of regsem 15 | namelist <- strsplit(names(object$out$pars)," ") # split names and operators 16 | inout <- data.frame(1,2) 17 | for(i in 1:length(namelist)){ 18 | inout[i,1] <- namelist[[i]][1] 19 | inout[i,2] <- namelist[[i]][3] 20 | } # create data frame of regsem variables 21 | 22 | int <- data.frame(1,2) 23 | for(i in 1:length(object1$lhs)){ 24 | int[i,1] <- ifelse(object1$op[i]=="~"|object1$op[i]=="~1",object1$rhs[i],object1$lhs[i]) 25 | int[i,2] <- ifelse(object1$op[i]=="~"|object1$op[i]=="~1",object1$lhs[i],object1$rhs[i]) 26 | } # create data frame of lavaan variables 27 | 28 | ## Paste together 29 | pinout <- with(inout, paste0(X1, X2)) 30 | pint <- with(int, paste0(X1, X2)) 31 | counter <- 0 32 | 33 | for(i in 1:length(pint)){ 34 | if(pint[i] %!in% pinout){ 35 | object1$regest[i] <- 1 36 | counter <- counter + 1 37 | } else { 38 | object1$regest[i] <- object$out$pars[i - counter] 39 | } 40 | } # match regsem estimates with lavaan variables, set fixed to 1 41 | 42 | 43 | ## Create a S4 list 44 | semModel <- new("semPlotModel") 45 | 46 | ## Create a Pars data frame 47 | semModel@Pars <- data.frame( 48 | label = rep("", length(object1$id)), 49 | lhs = ifelse(object1$op=="~"|object1$op=="~1",object1$rhs,object1$lhs), # first went from left to right without checking relationship 50 | edge = "--", 51 | rhs = ifelse(object1$op=="~"|object1$op=="~1",object1$lhs,object1$rhs), 52 | est = object1$regest, # check if we should take estimates from other model, if estimates are same as in regsem 53 | std = NA, 54 | group = object1$group, 55 | fixed = object1$free == 0, 56 | par = object1$free, 57 | stringsAsFactors=FALSE) 58 | row.names(semModel@Pars) <- 1:length(object1$id) 59 | 60 | ## translate operators 61 | semModel@Pars$edge[object1$op=="~~"] <- "<->" 62 | semModel@Pars$edge[object1$op=="~*~"] <- "<->" 63 | semModel@Pars$edge[object1$op=="~"] <- "~>" 64 | semModel@Pars$edge[object1$op=="=~"] <- "->" 65 | semModel@Pars$edge[object1$op=="~1"] <- "int" 66 | semModel@Pars$edge[grepl("\\|",object1$op)] <- "|" 67 | 68 | semModel@Pars <- semModel@Pars[!object$op%in%c(':=','<','>','==','|','<', '>'),] 69 | 70 | ## Create a vars data frame 71 | semModel@Vars <- data.frame( 72 | name = varnames, 73 | manifest = varnames[1:length(varnames)] %in% mannames$manifest[1:length(mannames$manifest)], 74 | exogenous = NA, 75 | stringsAsFactors = FALSE 76 | ) 77 | 78 | ## Miscellaneous data frames 79 | semModel@Thresholds <- data.frame() 80 | semModel@ObsCovs <- list() 81 | semModel@ImpCovs <- list() 82 | semModel@Computed <- FALSE 83 | semModel@Original <- list(object) 84 | 85 | return(semModel) 86 | } 87 | -------------------------------------------------------------------------------- /R/sem.R: -------------------------------------------------------------------------------- 1 | # semPaths.sem <- function(object,...) 2 | # { 3 | # invisible(semPaths(semPlotModel(object),...)) 4 | # } 5 | # 6 | # semPaths.msem <- function(object,...) 7 | # { 8 | # invisible(semPaths(semPlotModel(object),...)) 9 | # } 10 | # 11 | # semPaths.msemObjectiveML <- function(object,...) 12 | # { 13 | # invisible(semPaths(semPlotModel(object),...)) 14 | # } 15 | # 16 | 17 | 18 | ### SINGLE GROUP MODEL ### 19 | semPlotModel.sem <- function(object, ...) 20 | { 21 | 22 | # Check if object is of class "sem": 23 | if (!any(class(object)%in%c("sem","semmod"))) stop("Input must be a 'sem' object") 24 | 25 | # Define Pars: 26 | Pars <- data.frame( 27 | label = rownames(object$ram), 28 | lhs = object$ram[,3], 29 | edge = "--", 30 | rhs = object$ram[,2], 31 | est = object$ram[,5], 32 | std = standardizedCoefficients(object)[,2], 33 | group = 1, 34 | fixed = object$ram[,4]==0, 35 | par = object$ram[,4], 36 | stringsAsFactors=FALSE) 37 | 38 | # Extract parameter estimates: 39 | Pars$est[object$ram[,4]!=0] <- object$coef[object$ram[,4]] 40 | 41 | # Fix labels: 42 | for (i in unique(object$ram[,4][object$ram[,4]!=0])) 43 | { 44 | if (any(Pars$label[object$ram[,4]==i]=="") & any(Pars$label[object$ram[,4]==i]!="")) 45 | { 46 | Pars$label[object$ram[,4]==i & Pars$label==""] <- Pars$label[object$ram[,4]==i & Pars$label!=""] 47 | } 48 | } 49 | 50 | # Name variables: 51 | Pars$lhs <- object$var.names[Pars$lhs] 52 | Pars$rhs <- object$var.names[Pars$rhs] 53 | 54 | # Variable dataframe: 55 | Vars <- data.frame( 56 | name = object$var.names, 57 | manifest = object$var.names %in% colnames(object$S), 58 | exogenous = NA, 59 | stringsAsFactors=FALSE) 60 | 61 | # Define operators: 62 | Pars$edge[object$ram[,1]==2] <- "<->" 63 | Pars$edge[object$ram[,1]==1] <- "~>" 64 | # Pars$op[object$ram[,1]==1 & !Vars$manifest[match(Pars$lhs,Vars$name)] & Vars$manifest[match(Pars$rhs,Vars$name)]] <- "->" 65 | 66 | semModel <- new("semPlotModel") 67 | semModel@Pars <- Pars 68 | semModel@Vars <- Vars 69 | semModel@Computed <- TRUE 70 | semModel@Original <- list(object) 71 | semModel@ObsCovs <- list(object$S) 72 | semModel@ImpCovs <- list(object$C) 73 | 74 | return(semModel) 75 | } 76 | 77 | 78 | 79 | 80 | ### MUTLI GROUP MODEL ### 81 | semPlotModel.msem <- semPlotModel.msemObjectiveML <- function(object, ...) 82 | { 83 | 84 | nGroup <- length(object$ram) 85 | GroupNames <- object$groups 86 | 87 | ParsS <- list() 88 | stdobject <- standcoefmsem(object) 89 | 90 | for (g in 1:nGroup) 91 | { 92 | # Define Pars: 93 | Pars <- data.frame( 94 | label = rownames(object$ram[[g]]), 95 | lhs = object$ram[[g]][,3], 96 | edge = "", 97 | rhs = object$ram[[g]][,2], 98 | est = object$ram[[g]][,5], 99 | std = stdobject[[g]][,2], 100 | group = GroupNames[g], 101 | fixed = object$ram[[g]][,4]==0, 102 | par = object$ram[[g]][,4], 103 | stringsAsFactors=FALSE) 104 | 105 | # Extract parameter estimates: 106 | Pars$est[object$ram[[g]][,4]!=0] <- object$coef[object$ram[[g]][,4]] 107 | 108 | # Fix labels: 109 | for (i in unique(object$ram[[g]][,4][object$ram[[g]][,4]!=0])) 110 | { 111 | if (any(Pars$label[object$ram[[g]][,4]==i]=="") & any(Pars$label[object$ram[[g]][,4]==i]!="")) 112 | { 113 | Pars$label[object$ram[[g]][,4]==i & Pars$label==""] <- Pars$label[object$ram[[g]][,4]==i & Pars$label!=""] 114 | } 115 | } 116 | 117 | # Name variables: 118 | Pars$lhs <- object$var.names[[g]][Pars$lhs] 119 | Pars$rhs <- object$var.names[[g]][Pars$rhs] 120 | 121 | 122 | # Define operators: 123 | Pars$edge[object$ram[[g]][,1]==2] <- "<->" 124 | Pars$edge[object$ram[[g]][,1]==1] <- "->" 125 | 126 | ParsS[[g]] <- Pars 127 | } 128 | 129 | Pars <- do.call("rbind",ParsS) 130 | 131 | # Variable dataframe: 132 | Vars <- data.frame( 133 | name = unique(unlist(object$var.names)), 134 | manifest = unique(unlist(object$var.names)) %in% unique(c(sapply(object$S,colnames))), 135 | exogenous = NA, 136 | stringsAsFactors=FALSE) 137 | 138 | 139 | # Pars$op[object$ram[,1]==1 & !Vars$manifest[match(Pars$lhs,Vars$name)] & Vars$manifest[match(Pars$rhs,Vars$name)]] <- "->" 140 | 141 | semModel <- new("semPlotModel") 142 | semModel@Pars <- Pars 143 | semModel@Vars <- Vars 144 | semModel@Computed <- TRUE 145 | semModel@Original <- list(object) 146 | semModel@ObsCovs <- object$S 147 | semModel@ImpCovs <- object$C 148 | 149 | return(semModel) 150 | } 151 | -------------------------------------------------------------------------------- /R/semCors.R: -------------------------------------------------------------------------------- 1 | semCors <- function(object,include,vertical=TRUE,titles=FALSE,layout,maximum,...){ 2 | if (!"semPlotModel"%in%class(object)) object <- semPlotModel(object) 3 | 4 | if (!object@Computed) stop("SEM model has not been evaluated; there are no implied covariances") 5 | 6 | if (missing(layout)) layout <- NULL 7 | 8 | Ng <- max(sapply(list(object@ObsCovs,object@ImpCovs),length)) 9 | if (missing(include)) 10 | { 11 | include <- c("observed","expected")[c(length(object@ObsCovs)==Ng,length(object@ImpCovs)==Ng)] 12 | } 13 | Groups <- unique(object@Pars$group) 14 | 15 | l <- matrix(1:(Ng*length(include)),length(include),) 16 | if (vertical) layout(t(l)) else layout(l) 17 | 18 | Res <- list() 19 | 20 | for (g in 1:Ng) 21 | { 22 | Res[[g]] <- list() 23 | 24 | if (any(grepl("obs",include,ignore.case=TRUE))) 25 | { 26 | Res[[g]]$Observed <- qgraph(round(cov2cor(object@ObsCovs[[g]]),5),maximum=ifelse(missing(maximum),1,maximum),layout=layout,...) 27 | layout <- Res[[g]]$Observed$layout 28 | if (titles) 29 | { 30 | if (Ng > 1) 31 | { 32 | text(mean(par('usr')[1:2]),par("usr")[4],paste("Group",Groups[g],"(observed)"), adj = c(0.5,1)) 33 | } else { 34 | text(mean(par('usr')[1:2]),par("usr")[4],"Observed", adj = c(0.5,1)) 35 | } 36 | } 37 | } 38 | 39 | if (any(grepl("exp",include,ignore.case=TRUE)) | any(grepl("imp",include,ignore.case=TRUE))) 40 | { 41 | Res[[g]]$Implied <- qgraph(round(cov2cor(object@ImpCovs[[g]]),5),maximum=ifelse(missing(maximum),1,maximum),layout=layout,...) 42 | layout <- Res[[g]]$Implied$layout 43 | if (titles) 44 | { 45 | if (Ng > 1) 46 | { 47 | text(mean(par('usr')[1:2]),par("usr")[4],paste("Group",Groups[g],"(implied)"), adj = c(0.5,1)) 48 | } else { 49 | text(mean(par('usr')[1:2]),par("usr")[4],"Implied", adj = c(0.5,1)) 50 | } 51 | } 52 | } 53 | 54 | 55 | if (any(grepl("dif",include,ignore.case=TRUE)) | any(grepl("res",include,ignore.case=TRUE))) 56 | { 57 | Res[[g]]$Difference <- qgraph(round(cov2cor(object@ObsCovs[[g]]) - cov2cor(object@ImpCovs[[g]]),5),maximum=ifelse(missing(maximum),.1,maximum),layout=layout,diag = TRUE, ...) 58 | if (titles) 59 | { 60 | if (Ng > 1) 61 | { 62 | text(mean(par('usr')[1:2]),par("usr")[4],paste("Group",Groups[g],"(observed - implied)"), adj = c(0.5,1)) 63 | } else { 64 | text(mean(par('usr')[1:2]),par("usr")[4],"Observed - Implied", adj = c(0.5,1)) 65 | } 66 | } 67 | } 68 | 69 | 70 | } 71 | 72 | invisible(Res) 73 | } -------------------------------------------------------------------------------- /R/semMatrixAlgebra.R: -------------------------------------------------------------------------------- 1 | semMatrixAlgebra <- function(object, algebra, group, simplify = TRUE, model, endoOnly = FALSE) 2 | { 3 | # Check if input is combination of models: 4 | call <- paste(deparse(substitute(object)), collapse = "") 5 | if (grepl("\\+",call)) 6 | { 7 | args <- unlist(strsplit(call,split="\\+")) 8 | obs <- lapply(args,function(x)semPlotModel(eval(parse(text=x)))) 9 | object <- obs[[1]] 10 | for (i in 2:length(obs)) object <- object + obs[[i]] 11 | } 12 | 13 | if ("lisrel"%in%class(object)) object <- object$matrices 14 | if (!"semMatrixModel"%in%class(object)) 15 | { 16 | if (missing(model)) 17 | { 18 | if (any(grepl("(LY)|(TE)|(PS)|(BE)|(LX)|(TD)|(PH)|(GA)|(TY)|(TX)|(AL)|(KA)",deparse(substitute(algebra))))) { 19 | model <- "lisrel" 20 | message("model set to 'lisrel'") 21 | } else if (any(grepl("(Lambda)|(Nu)|(Theta)|(Kappa)|(Alpha)|(Beta)|(Gamma)|(Psi)",deparse(substitute(algebra))))) 22 | { 23 | model <- "mplus" 24 | message("model set to 'mplus'") 25 | } else if (any(grepl("A|S|F",deparse(substitute(algebra))))) 26 | { 27 | model <- "ram" 28 | message("model set to 'ram'") 29 | } else stop("'model' could not be detected") 30 | } 31 | object <- modelMatrices(object,model,endoOnly = endoOnly) 32 | } 33 | stopifnot("semMatrixModel"%in%class(object)) 34 | 35 | if (missing(group)) group <- seq_len(max(sapply(object,length))) 36 | 37 | Mats <- lapply(object,lapply,'[[','est') 38 | Res <- list() 39 | for (i in seq_along(group)) 40 | { 41 | GroupMats <- lapply(Mats,'[[',i) 42 | Res[[i]] <- eval(substitute(algebra), GroupMats) 43 | } 44 | 45 | if (simplify) if (length(Res)==1) Res <- Res[[1]] 46 | return(Res) 47 | } -------------------------------------------------------------------------------- /R/semPathsHelperFuns.R: -------------------------------------------------------------------------------- 1 | 2 | ## Mode function: 3 | Mode <- function(x) { 4 | ux <- unique(x) 5 | ux[which.max(tabulate(match(x, ux)))] 6 | } 7 | 8 | # Function to scale and rotate layouts: 9 | LayoutScaler <- function(x, xrange=1, yrange=1) 10 | { 11 | 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 12 | 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 13 | 14 | x[,1] <- x[,1] * xrange 15 | x[,2] <- x[,2] * yrange 16 | 17 | return(x) 18 | } 19 | 20 | # Rotation function: 21 | RotMat <- function(d,w2hrat=1) 22 | { 23 | matrix(c(cos(-d),sin(-d),-sin(-d),cos(-d)),2,2) 24 | } 25 | 26 | 27 | ## Function to compute reingold-tilford layout using igraph: 28 | rtLayout <- function(roots,GroupPars,Edgelist,layout,exoMan) 29 | { 30 | # Reverse intercepts in graph: 31 | # revNodes <- which((GroupPars$edge == "int" | Edgelist[,2] %in% exoMan) & !Edgelist[,1] %in% roots ) 32 | # revNodes <- which((GroupPars$edge == "int" & !Edgelist[,1] %in% roots) | Edgelist[,2] %in% exoMan ) 33 | # Edgelist[revNodes,1:2] <- Edgelist[revNodes,2:1] 34 | # Remove double headed arrows: 35 | Edgelist <- Edgelist[GroupPars$edge != "<->",] 36 | 37 | # Make igraph object: 38 | Graph <- graph.edgelist(Edgelist, FALSE) 39 | # Compute layout: 40 | Layout <- layout.reingold.tilford(Graph,root=roots,circular = FALSE) 41 | 42 | return(Layout) 43 | } 44 | 45 | ## Function to mix color vector x with weight w 46 | mixColfun <- function(x,w) 47 | { 48 | # x = vector of colors 49 | # w = weights 50 | if (missing(w)) w <- rep(1,length(x)) 51 | if (length(w)==1) w <- rep(w,length(x)) 52 | ## w == 0 leads to NaN from weighted.mean() 53 | w[w <= 0] <- 0.0000001 54 | 55 | RGB <- col2rgb(x) 56 | wMeans <- apply(RGB,1,weighted.mean,w=w) 57 | return(rgb(wMeans[1],wMeans[2],wMeans[3],maxColorValue=255)) 58 | } 59 | 60 | loopOptim <- function(x,Degrees) 61 | { 62 | 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)))) 63 | Dist2Edges <- sapply(Degrees,function(d)min(abs(x - c(d,d-2*pi,d+2*pi)))) 64 | return(NotinRange * 2 * pi * 2 + sum(sort(Dist2Edges)[1:2])) 65 | } 66 | 67 | # RotMat <- function(d) matrix(c(cos(-d),sin(-d),-sin(-d),cos(-d)),2,2) 68 | 69 | mixInts <- function(vars,intMap,Layout,trim=FALSE,intAtSide=TRUE) 70 | { 71 | n <- length(vars) 72 | 73 | if (intAtSide) 74 | { 75 | if (!trim) 76 | { 77 | if (n+nrow(intMap)==1) 78 | { 79 | sq <- 0 80 | } 81 | if (n+nrow(intMap) == 2) 82 | { 83 | sq <- c(0,0.5) 84 | } else { 85 | sq <- seq(-1,1,length=n+nrow(intMap)) 86 | } 87 | } else { 88 | if (n+nrow(intMap) == 2) 89 | { 90 | sq <- c(0,0.5) 91 | } else { 92 | sq <- seq(-1,1,length=n+nrow(intMap)+2)[-c(1,n+nrow(intMap)+2)] 93 | } 94 | } 95 | cent <- median(1:n) 96 | c <- 1 97 | for (i in seq_along(vars)) 98 | { 99 | if (vars[i]%in%intMap[,2]) 100 | { 101 | if (i < cent) 102 | { 103 | Layout[intMap[intMap[,2]==vars[i],1],1] <- sq[c] 104 | Layout[vars[i],1] <- sq[c+1] 105 | c <- c+2 106 | } else 107 | { 108 | Layout[intMap[intMap[,2]==vars[i],1],1] <- sq[c+1] 109 | Layout[vars[i],1] <- sq[c] 110 | c <- c+2 111 | } 112 | } else 113 | { 114 | Layout[vars[i],1] <- sq[c] 115 | c <- c+1 116 | } 117 | } 118 | } else { 119 | if (!trim) 120 | { 121 | if (n==1) 122 | { 123 | sq <- 0 124 | } else if (n == 2) 125 | { 126 | sq <- c(-1,1) 127 | } else { 128 | sq <- seq(-1,1,length=n) 129 | } 130 | } else { 131 | if (n == 1) 132 | { 133 | sq <- 0 134 | } else if (n == 2) 135 | { 136 | sq <- c(-0.5,0.5) 137 | } else { 138 | sq <- seq(-1,1,length=n+2)[-c(1,n+2)] 139 | } 140 | } 141 | c <- 1 142 | for (i in seq_along(vars)) 143 | { 144 | if (vars[i]%in%intMap[,2]) 145 | { 146 | Layout[intMap[intMap[,2]==vars[i],1],1] <- sq[c] 147 | Layout[vars[i],1] <- sq[c] 148 | c <- c + 1 149 | } else 150 | { 151 | Layout[vars[i],1] <- sq[c] 152 | c <- c+1 153 | } 154 | } 155 | } 156 | return(Layout) 157 | } 158 | -------------------------------------------------------------------------------- /R/semSyntax.R: -------------------------------------------------------------------------------- 1 | semSyntax <- function(object, syntax = "lavaan", allFixed = FALSE, file) 2 | { 3 | if (!"semPlotModel" %in% class(object)) 4 | { 5 | # Try to run semPlotModel on object, otherwise stop. 6 | object <- semPlotModel(object) 7 | } 8 | if (!syntax %in% c("lavaan","sem")) stop("Only 'lavaan' and 'sem' syntax is currently supported ") 9 | 10 | if (nrow(object@Thresholds) > 0) warning("Thresholds are not yet supported by semSyntax") 11 | 12 | # If all fixed, simply set all fixed = TRUE: 13 | if (allFixed) 14 | { 15 | object@Pars$fixed <- TRUE 16 | } 17 | 18 | ### LAVAAN ### 19 | if (syntax == "lavaan") 20 | { 21 | Pars <- object@Pars 22 | 23 | # Reverse lhs and rhs: 24 | Pars[Pars$edge %in% c('~>','int'),c('lhs','rhs')] <- Pars[Pars$edge %in% c('~>','int'),c('rhs','lhs')] 25 | 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')] 26 | 27 | # Change operators: 28 | Pars$edge[Pars$edge=='->'&!(Pars$lhs%in%object@Vars$name[!object@Vars$manifest] & Pars$rhs%in%object@Vars$name[object@Vars$manifest])] <- "~" 29 | Pars$edge[Pars$edge=='->'&(Pars$lhs%in%object@Vars$name[!object@Vars$manifest] & Pars$rhs%in%object@Vars$name[object@Vars$manifest])] <- "=~" 30 | Pars$edge[Pars$edge == "~>"] <- "~" 31 | Pars$edge[Pars$edge == "<->"] <- "~~" 32 | Pars$rhs[Pars$edge == "int"] <- "1" 33 | Pars$edge[Pars$edge == "int"] <- "~" 34 | 35 | 36 | # Fixing parameters: 37 | Pars$rhs <- ifelse( Pars$fixed, paste0(Pars$est,"*",Pars$rhs), Pars$rhs) 38 | Pars$rhs <- ifelse( !Pars$fixed & Pars$par > 0 & (duplicated(Pars$par)|duplicated(Pars$par,fromLast=TRUE)), paste0("par",Pars$par,"*",Pars$rhs), Pars$rhs) 39 | 40 | # Combine and return: 41 | Mod <- paste(Pars$lhs,Pars$edge,Pars$rhs,collapse = "\n") 42 | 43 | # Print to console or file: 44 | if (missing(file)) 45 | { 46 | cat("\nModel <- '\n",Mod,"\n'\n",sep="") 47 | } else 48 | { 49 | write(paste0("\nModel <- '\n",Mod,"\n'\n"),file) 50 | } 51 | 52 | return(Mod) 53 | } 54 | 55 | ### SEM ### 56 | if (syntax == "sem") 57 | { 58 | 59 | Pars <- object@Pars 60 | 61 | # Remove intercepts: 62 | if (any(Pars$edge == "int")) 63 | { 64 | warning("Intercepts removed from model for 'sem' syntax") 65 | Pars <- Pars[Pars$edge!="int",] 66 | } 67 | 68 | Pars$label[Pars$fixed] <- NA 69 | ## Fix parameter labels. 70 | if (max(Pars$par) > 0) 71 | { 72 | for (i in seq_len(max(Pars$par))) 73 | { 74 | # Check if unique to other par numbers: 75 | if (any(Pars$label[Pars$par!=i] %in% Pars$label[Pars$par==i] | any(Pars$label[Pars$par == i] == ''))) 76 | { 77 | Pars$label[Pars$par==i] <- paste0("par",i) 78 | } 79 | 80 | # Check if labels are unique, else combine: 81 | if (length(unique(Pars$label[Pars$par == i])) > 1) 82 | { 83 | Pars$label[Pars$par==i] <- paste(Pars$label[Pars$par==i],collapse="_") 84 | } 85 | } 86 | } 87 | 88 | # Fix estimate: 89 | Pars$est[!Pars$fixed] <- NA 90 | 91 | # Fix edges: 92 | Pars$edge[Pars$edge == '~>'] <- '->' 93 | 94 | # Create model: 95 | Mod <- paste(paste(Pars$lhs, Pars$edge, Pars$rhs), Pars$label, Pars$est, sep = ",", collapse = "\n") 96 | 97 | # Print to console or file: 98 | if (missing(file)) 99 | { 100 | cat("\nModel <- specifyModel()\n",Mod,"\n\n",sep="") 101 | } else 102 | { 103 | write(paste0("\nModel <- specifyModel()\n",Mod,"\n\n",sep=""),file) 104 | } 105 | 106 | Mod <- specifyModel( textConnection( Mod )) 107 | 108 | return(Mod) 109 | } 110 | 111 | 112 | 113 | } -------------------------------------------------------------------------------- /R/semspec.R: -------------------------------------------------------------------------------- 1 | ## This function is commented out because semspec is not yet on CRAN. For the full version of this function please see 2 | ## www.sachaepskamp.com/semPlot 3 | 4 | semPlotModel.semspec <- function(object) 5 | { 6 | 7 | stop("This function is not included in the CRAN release because semspec is not on CRAN. Please see www.sachaepskamp.com for the function") 8 | # 9 | # # Load 'semspec': 10 | # if (!require("semspec")) stop('semspec is required: install.packages("semspec", repos="http://R-Forge.R-project.org")') 11 | # 12 | # semreprObject <- semrepr(object) 13 | # sumObject <- summary(object) 14 | # 15 | # # Define Pars: 16 | # Pars <- data.frame( 17 | # label = "", 18 | # lhs = semreprObject$lhs, 19 | # edge = "--", 20 | # rhs = semreprObject$rhs, 21 | # est = NA, 22 | # std = NA, 23 | # group = ifelse(is.na(semreprObject$group),"",semreprObject$group), 24 | # fixed = FALSE, 25 | # par = 0, 26 | # stringsAsFactors=FALSE) 27 | # 28 | # # Label: 29 | # if (!is.null(semreprObject$param)) Pars$label <- semreprObject$param 30 | # 31 | # 32 | # # Fixed: 33 | # # if (!is.null(semreprObject$free)) Pars$fixed <- !semreprObject$free 34 | # if (length(sumObject$constraints$details$Constraint)>0) 35 | # { 36 | # spl <- strsplit(sumObject$constraints$details$Constraint,split=" == ")[grepl("==",sumObject$constraints$details$Constraint)] 37 | # parNum <- sapply(spl,function(x)sum(x%in%Pars$label)) 38 | # parIt <- 1 39 | # for (p in 1:length(spl)) 40 | # { 41 | # if (parNum[p]==1) 42 | # { 43 | # Pars$fixed[Pars$label%in%spl[[p]]] <- TRUE 44 | # } else if (parNum[p]==2) 45 | # { 46 | # Pars$par[Pars$label%in%spl[[p]]] <- parIt 47 | # parIt <- parIt + 1 48 | # } else warning("Error in computation of equality constraints.") 49 | # } 50 | # } 51 | # 52 | # if (max(Pars$par) < nrow(Pars)) 53 | # { 54 | # Pars$par[Pars$par==0] <- max(Pars$par)+(1:sum(Pars$par==0)) 55 | # } 56 | # 57 | # # Extract parameter estimates: 58 | # Pars$est[object$ram[,4]!=0] <- object$coef[object$ram[,4]] 59 | # 60 | # # Switch sides in regression: 61 | # Pars[c("lhs","rhs")][semreprObject$type=="regression",] <- Pars[c("rhs","lhs")][semreprObject$type=="regression",] 62 | # 63 | # # Set edges: 64 | # Pars$edge[semreprObject$type=="regression"] <- "~>" 65 | # Pars$edge[semreprObject$type=="latent"] <- "->" 66 | # Pars$edge[semreprObject$type=="covariance"] <- "<->" 67 | # Pars$edge[semreprObject$type=="intercept"] <- "int" 68 | # 69 | # # Variable dataframe: 70 | # Vars <- data.frame( 71 | # name = sumObject$variables$details$Variable, 72 | # manifest = sumObject$variables$details$Type == "Manifest", 73 | # exogenous = NA, 74 | # stringsAsFactors=FALSE) 75 | # 76 | # # If all are latent, make guess at which are latent: 77 | # if (all(!Vars$manifest)) 78 | # { 79 | # for (i in 1:nrow(Vars)) 80 | # { 81 | # Vars$manifest[i] <- !any(semreprObject$type[semreprObject$lhs==Vars$name[i]]=="latent") 82 | # } 83 | # } 84 | # 85 | # semModel <- new("semPlotModel") 86 | # semModel@Pars <- Pars 87 | # semModel@Vars <- Vars 88 | # semModel@Computed <- FALSE 89 | # semModel@Original <- list() 90 | # semModel@ObsCovs <- list() 91 | # semModel@ImpCovs <- list() 92 | # 93 | # return(semModel) 94 | } 95 | 96 | -------------------------------------------------------------------------------- /R/semstandmsem.R: -------------------------------------------------------------------------------- 1 | # Original code from sem package, by John Fox and Adam Kramer. 2 | 3 | standcoefmsem <- function (object, ...) 4 | { 5 | Res <- list() 6 | groups <- object$groups 7 | G <- length(groups) 8 | param.names <- object$param.names 9 | ram <- object$ram 10 | A <- object$A 11 | P <- object$P 12 | par <- coef(object) 13 | for (g in 1:G) { 14 | par.names <- param.names[ram[[g]][, 4]] 15 | par.gr <- par[par.names] 16 | t <- length(par.gr) 17 | par.posn <- ram[[g]][, 4] != 0 18 | ram[[g]][par.posn, 4] <- 1:t 19 | group <- list(coeff = par.gr, t = t, ram = ram[[g]], 20 | A = A[[g]], P = P[[g]], par.posn = par.posn, param.names = par.names) 21 | class(group) <- "sem" 22 | Res[[g]] <- standardizedCoefficients(group, ...) 23 | } 24 | return(Res) 25 | } -------------------------------------------------------------------------------- /R/standardizeRAM_2.R: -------------------------------------------------------------------------------- 1 | # function: standardizeRAM 2 | # author: Ryne Estabrook 3 | # date: 20 Oct 2010 4 | # revised: 01 Nov 2010 (corrected algebra) 5 | # 13 Dec 2010 (corrected 'parameters' output) 6 | 7 | standardizeRAM <- function(model, return="parameters", Amat=NA, Smat=NA, Mmat=NA){ 8 | # make sure 'return' is valid 9 | if (!(return=="parameters"|return=="matrices"|return=="model"))stop("Invalid 'return' parameter. What do you want from me?") 10 | # get the name of the objective 11 | obj <- class(model@objective)[1] 12 | suppliedNames <- !is.na(Amat)&!is.na(Smat) 13 | cA <- is.character(Amat) 14 | cS <- is.character(Smat) 15 | cM <- is.character(Mmat) 16 | # if the objective function isn't RAMObjective, you need to supply Amat and Smat 17 | if (obj!="MxRAMObjective"&(!cA))stop("I need either mxRAMObjective or the names of the A and S matrices.") 18 | output <- model@output 19 | # stop if there is no objective function 20 | if (is.null(output))stop("Provided model has no objective function, and thus no output. I can only standardize models that have been run!") 21 | # stop if there is no output 22 | if (length(output)<1)stop("Provided model has no output. I can only standardize models that have been run!") 23 | # get the names of the A, S and M matrices 24 | if (cA){nA <- Amat} else {nA <- model@objective@A} 25 | if (cS){nS <- Smat} else {nS <- model@objective@S} 26 | if (cM){nM <- Mmat} else {nM <- model@objective@M} 27 | # get the actual A and S matrices, and make an identity matrix 28 | A <- model[[nA]] 29 | S <- model[[nS]] 30 | d <- dim(S@values)[1] 31 | I <- diag(d) 32 | # calculate the model expected covariance matrix 33 | IA <- solve(I-A@values) 34 | expCov <- IA %*% S@values %*% t(IA) 35 | # calculate 1/SDs and put them in a diagonal matrix 36 | invSDs <- 1/sqrt(diag(expCov)) 37 | # give the inverse SDs names, because mxSummary treats column names as characters 38 | names(invSDs) <- as.character(1:length(invSDs)) 39 | if (!is.null(dimnames(A@values))){names(invSDs) <- as.vector(dimnames(S@values)[[2]])} 40 | # put the inverse SDs into a diagonal matrix (might as well recycle my I matrix from above) 41 | diag(I) <- invSDs 42 | # standardize the A, S and M matrices 43 | # A paths are value*sd(from)/sd(to) = I %*% A %*% solve(I) 44 | # S paths are value/(sd(from*sd(to))) = I %*% S %*% I 45 | stdA <- I %*% A@values %*% solve(I) 46 | stdS <- I %*% S@values %*% I 47 | # populate the model 48 | model[[nA]]@values[,] <- stdA 49 | model[[nS]]@values[,] <- stdS 50 | if (!is.na(nM)){model[[nM]]@values[,] <- rep(0, length(invSDs))} 51 | # return the model, if asked 52 | if(return=="model")return(model) 53 | # return the matrices, if asked 54 | matrices <- list(model[[nA]], model[[nS]]) 55 | names(matrices) <- c("A", "S") 56 | if(return=="matrices")return(matrices) 57 | # else, return the parameters 58 | # let's rebuild the parameter list 59 | p <- summary(model)$parameters 60 | p <- p[(p[,2]==nA)|(p[,2]==nS),] 61 | ## get the rescaling factor 62 | # this is for the A matrix 63 | rescale <- invSDs[p$row] * 1/invSDs[p$col] 64 | # this is for the S matrix 65 | rescaleS <- invSDs[p$row] * invSDs[p$col] 66 | # put the A and the S together 67 | rescale[p$matrix=="S"] <- rescaleS[p$matrix=="S"] 68 | # rescale 69 | p[,5] <- p[,5] * rescale 70 | p[,6] <- p[,6] * rescale 71 | # rename the columns 72 | names(p)[5:6] <- c("Std. Estimate", "Std.Std.Error") 73 | # bye! 74 | return(p) 75 | } -------------------------------------------------------------------------------- /R/zzz.R: -------------------------------------------------------------------------------- 1 | # I copied this piece of code from Lavaan mainly: 2 | # 3 | # .onAttach <- function(libname, pkgname) { 4 | # version <- read.dcf(file=system.file("DESCRIPTION", package=pkgname), 5 | # fields="Version") 6 | # packageStartupMessage("This is ",paste(pkgname, version)) 7 | # packageStartupMessage(pkgname, " is BETA software! Please report any bugs.") 8 | # } -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Path diagrams and visual analysis of various SEM packages' output. 2 | 3 | Please ask questions here or on http://sachaepskamp.com/forums/semPlot. 4 | -------------------------------------------------------------------------------- /inst/COPYRIGHTS: -------------------------------------------------------------------------------- 1 | COPYRIGHT STATUS 2 | ---------------- 3 | 4 | This code is 5 | 6 | Copyright (C) 2013, 2014, 2015, 2016, 2017 Sacha Epskamp 7 | 8 | All code is subject to the GNU General Public License, Version 2. See 9 | the file COPYING for the exact conditions under which you may 10 | redistribute it. 11 | -------------------------------------------------------------------------------- /man/Imin.Rd: -------------------------------------------------------------------------------- 1 | \name{Imin} 2 | \alias{Imin} 3 | %- Also NEED an '\alias' for EACH other topic documented here. 4 | \title{ 5 | Helper function to substract matrix from identity matrix and take inverse. 6 | } 7 | \description{ 8 | This function can be used to more easilly compute I - X or (I - X)^(-1), which are common in SEM models. 9 | } 10 | \usage{ 11 | Imin(x, inverse = FALSE) 12 | } 13 | %- maybe also 'usage' for other objects documented here. 14 | \arguments{ 15 | \item{x}{ 16 | A matrix 17 | } 18 | \item{inverse}{ 19 | Logical, should the inverse be taken? 20 | } 21 | } 22 | 23 | \author{ 24 | Sacha Epskamp 25 | } 26 | -------------------------------------------------------------------------------- /man/cvregsemplot.Rd: -------------------------------------------------------------------------------- 1 | \name{cvregsem} 2 | \alias{semPlotModel.cvregsem} 3 | \title{ 4 | Bridge between cv_regsem output and sempaths 5 | } 6 | \description{ 7 | 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. 8 | } 9 | \usage{ 10 | \method{semPlotModel}{cvregsem}(object,model,\dots) 11 | } 12 | \arguments{ 13 | \item{object}{ 14 | The regsem output 15 | } 16 | 17 | \item{model}{ 18 | The cfa output used as input for the cv_regsem function 19 | } 20 | \item{\dots}{ 21 | Arguments sent to 'lisrelModel', not used in other methods. 22 | } 23 | 24 | } 25 | 26 | \value{ 27 | A 'semPlotModel' object. 28 | } 29 | \references{ 30 | Jacobucci, R. (2017). regsem: Regularized Structural Equation Modeling. arXiv preprint arXiv:1703.08489. 31 | } 32 | \author{ 33 | Sacha Epskamp 34 | Jason Nak 35 | Myrthe Veenman 36 | } 37 | 38 | \seealso{ 39 | \code{\link{semPlotModel}} 40 | \code{\link{semPaths}} 41 | } 42 | \examples{ 43 | ## Example of fitting and plotting a cv_regsem model in semPaths 44 | 45 | #library(psych) 46 | #library(lavaan) 47 | #library(regsem) 48 | 49 | # use a subset of the BFI 50 | #bfi2 <- bfi[1:250,c(1:5,18,22)] 51 | #bfi2[,1] <- reverse.code(-1,bfi2[,1]) 52 | 53 | # specify a SEM model 54 | #mod <- " 55 | #f1 =~ NA*A1+A2+A3+A4+A5+O2+N3 56 | #f1~~1*f1 57 | #" 58 | 59 | # fit the model 60 | #fit <- cfa(mod, bfi2) 61 | #out.reg <- cv_regsem(fit, type="lasso", pars_pen=c(1:7), n.lambda=23, jump =.05) 62 | 63 | # plot the model 64 | #semPaths(semPlotModel.cvregsemplot(object = out.reg, model = fit)) 65 | } 66 | 67 | -------------------------------------------------------------------------------- /man/edits.Rd: -------------------------------------------------------------------------------- 1 | \name{semPlotModel-edit} 2 | \alias{semPlotModel-edit} 3 | \alias{exo} 4 | \alias{exo<-} 5 | \alias{endo} 6 | \alias{endo<-} 7 | \alias{man} 8 | \alias{man<-} 9 | \alias{lat} 10 | \alias{lat<-} 11 | \title{ 12 | Functions to facilitate editting 'semPlotModel' objects. 13 | } 14 | \description{ 15 | 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. 16 | } 17 | \usage{ 18 | exo(x) 19 | endo(x) 20 | man(x) 21 | lat(x) 22 | } 23 | %- maybe also 'usage' for other objects documented here. 24 | \arguments{ 25 | \item{x}{ 26 | A \code{"semPlotModel"} object 27 | } 28 | } 29 | \author{ 30 | Sacha Epskamp 31 | } 32 | \seealso{ 33 | \code{\link{semPlotModel}} 34 | } 35 | -------------------------------------------------------------------------------- /man/lisrelModel.Rd: -------------------------------------------------------------------------------- 1 | \name{lisrelModel} 2 | \alias{lisrelModel} 3 | %- Also NEED an '\alias' for EACH other topic documented here. 4 | \title{ 5 | Construct SEM model using LISREL matrix specification. 6 | } 7 | \description{ 8 | 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. 9 | } 10 | \usage{ 11 | lisrelModel(LY, PS, BE, TE, TY, AL, manNamesEndo, latNamesEndo, LX, PH, GA, TD, 12 | TX, KA, manNamesExo, latNamesExo, ObsCovs, ImpCovs, setExo, modelLabels = FALSE, 13 | reduce) 14 | } 15 | %- maybe also 'usage' for other objects documented here. 16 | \arguments{ 17 | \item{LY}{ 18 | Specification of the Lambda-Y matrix. See details. 19 | } 20 | \item{PS}{ 21 | Specification of the Psi matrix. See details. 22 | } 23 | \item{BE}{ 24 | Specification of the Beta matrix. See details. 25 | } 26 | \item{TE}{ 27 | Specification of the Theta-Epsilon matrix. See details. 28 | } 29 | \item{TY}{ 30 | Specification of the Tau-Y matrix. See details. 31 | } 32 | \item{AL}{ 33 | Specification of the Alpha matrix. See details. 34 | } 35 | \item{manNamesEndo}{ 36 | Character vector of names for the endogenous manifests. 37 | } 38 | \item{latNamesEndo}{ 39 | Character vector of names for the endogenous latents. 40 | } 41 | \item{LX}{ 42 | Specification of the Lambda-X matrix. See details. 43 | } 44 | \item{PH}{ 45 | Specification of the Phi matrix. See details. 46 | } 47 | \item{GA}{ 48 | Specification of the Gamma matrix. See details. 49 | } 50 | \item{TD}{ 51 | Specification of the Theta-Delta matrix. See details. 52 | } 53 | \item{TX}{ 54 | Specification of the Tau-X matrix. See details. 55 | } 56 | \item{KA}{ 57 | Kappa 58 | } 59 | \item{manNamesExo}{ 60 | Character vector of names for the exogenous manifests. 61 | } 62 | \item{latNamesExo}{ 63 | Character vector of names for the exogenous latents. 64 | } 65 | \item{ObsCovs}{ 66 | The observed covariance matrix, or a list of such matrices for each group. 67 | } 68 | \item{ImpCovs}{ 69 | The implied covariance matrix, or a list of such matrices for each group. 70 | } 71 | \item{setExo}{ 72 | 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. 73 | } 74 | \item{modelLabels}{ 75 | 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")}. 76 | } 77 | \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.} 78 | } 79 | \details{ 80 | The LISREL matrices can be assigned in various ways, depending on the amount of information that should be stored in the resulting model. 81 | 82 | 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. 83 | 84 | 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): 85 | \describe{ 86 | \item{\code{est}}{Parameter estimates} 87 | \item{\code{std}}{standardized parameter estimates} 88 | \item{\code{par}}{Parameter numbers. 0 indicating fixed variables and parameters with the same parameter number are constrained to be equal.} 89 | \item{\code{fixed}}{Logical matrix indicating if the parameter is fixed.} 90 | } 91 | 92 | 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. 93 | 94 | 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. 95 | } 96 | \value{ 97 | A 'semPlotModel' object. 98 | } 99 | \references{ 100 | Joreskog, K. G., & Sorbom, D. (1996). LISREL 8 user's reference guide. Scientific Software. 101 | 102 | https://github.com/SachaEpskamp/lisrelToR 103 | } 104 | \author{ 105 | Sacha Epskamp 106 | } 107 | 108 | \seealso{ 109 | \code{\link{semPlotModel}} 110 | \code{\link{semCors}} 111 | \code{\link{semPaths}} 112 | \code{\link{ramModel}} 113 | } 114 | 115 | \examples{ 116 | ## Example of a Full LISREL model path diagram with the same number of exgenous 117 | ## and endogenous variables: 118 | 119 | # Lambda matrices: 120 | Loadings <- rbind(diag(1,2,2),diag(1,2,2),diag(1,2,2)) 121 | 122 | # Phi and Psi matrices: 123 | LatVar <- diag(1,2,2) 124 | 125 | # Beta matrix: 126 | Beta <- matrix(0,2,2) 127 | Beta[1,2] <- 1 128 | 129 | # Theta matrices: 130 | ManVar <- diag(1,nrow(Loadings),nrow(Loadings)) 131 | 132 | # Gamma matrix: 133 | Gamma <- diag(1,2,2) 134 | 135 | # Tau matrices: 136 | ManInts <- rep(1,6) 137 | 138 | # Alpha and Kappa matrices: 139 | LatInts <- rep(1,2) 140 | 141 | # Combine model: 142 | mod <- lisrelModel(LY=Loadings,PS=LatVar,BE=Beta,TE=ManVar, 143 | LX=Loadings,PH=LatVar,GA=Gamma,TD=ManVar, 144 | TY=ManInts,TX=ManInts,AL=LatInts,KA=LatInts) 145 | 146 | # Plot path diagram: 147 | semPaths(mod, as.expression=c("nodes","edges"), sizeMan = 3, sizeInt = 1, 148 | sizeLat = 4) 149 | 150 | # Plot path diagram with more graphical options: 151 | semPaths(mod, as.expression=c("nodes","edges"), sizeMan = 3, sizeInt = 1, 152 | sizeLat = 4, label.prop=0.5, curve=0.5, bg="black", groups="latents", 153 | intercepts=FALSE, borders=FALSE, label.norm="O") 154 | 155 | } 156 | -------------------------------------------------------------------------------- /man/modelMatrices.Rd: -------------------------------------------------------------------------------- 1 | \name{modelMatrices} 2 | \alias{modelMatrices} 3 | %- Also NEED an '\alias' for EACH other topic documented here. 4 | \title{ 5 | Extract SEM model matrices 6 | } 7 | \description{ 8 | 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. 9 | } 10 | \usage{ 11 | modelMatrices(object, model = "ram", endoOnly = FALSE) 12 | } 13 | %- maybe also 'usage' for other objects documented here. 14 | \arguments{ 15 | \item{object}{ 16 | A \code{"semPlotModel"} object or any of the input types that can be used in \code{\link{semPlotModel}} directly. 17 | } 18 | \item{model}{ 19 | Model to be used, \code{"mplus"}, \code{"ram"} or \code{"lisrel"} 20 | } 21 | \item{endoOnly}{ 22 | Only needed when the model is \code{"lisrel"}, sets all variables to endogenous. 23 | } 24 | } 25 | \details{ 26 | 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. 27 | 28 | 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}. 29 | 30 | The \code{"ram"} model uses the following matrix names: \code{F}, \code{A} and \code{S}. 31 | } 32 | \value{ 33 | a \code{"semMatriModel"} object 34 | } 35 | \author{ 36 | Sacha Epskamp 37 | } 38 | 39 | \seealso{ 40 | \code{\link{semPlotModel}} 41 | \code{\link{semPlotModel-class}} 42 | \code{\link{semMatrixAlgebra}} 43 | \code{\link{lisrelModel}} 44 | \code{\link{ramModel}} 45 | } 46 | 47 | \examples{ 48 | ## Mplus user guide SEM example: 49 | outfile <- tempfile(fileext=".out") 50 | tryres <- try({ 51 | download.file("http://www.statmodel.com/usersguide/chap5/ex5.11.html",outfile) 52 | }) 53 | 54 | if (!is(tryres,"try-error")){ 55 | # Plot model: 56 | semPaths(outfile, intercepts = FALSE) 57 | 58 | # Extract RAM: 59 | RAM <- modelMatrices(outfile, "ram") 60 | semPaths(do.call(ramModel, RAM), as.expression = "edges", intercepts = FALSE) 61 | 62 | # Extract LISREL: 63 | LISREL <- modelMatrices(outfile, "lisrel") 64 | semPaths(do.call(lisrelModel, LISREL), as.expression = "edges", intercepts = FALSE) 65 | } 66 | } 67 | 68 | -------------------------------------------------------------------------------- /man/ramModel.Rd: -------------------------------------------------------------------------------- 1 | \name{ramModel} 2 | \alias{ramModel} 3 | %- Also NEED an '\alias' for EACH other topic documented here. 4 | \title{ 5 | Construct SEM model using RAM matrix specification. 6 | } 7 | \description{ 8 | This function creates a 'semPlotModel' object using matrices of the RAM model (McArdle & McDonald, 1984). 9 | } 10 | \usage{ 11 | ramModel(A, S, F, M, manNames, latNames, Names, ObsCovs, ImpCovs, modelLabels = FALSE) 12 | } 13 | %- maybe also 'usage' for other objects documented here. 14 | \arguments{ 15 | \item{A}{ 16 | Specification of the assymmetric (A) matrix, see details. 17 | } 18 | \item{S}{ 19 | Specification of the symmetric (S) matrix, see details. 20 | } 21 | \item{F}{ 22 | Specification of the filter (F) matrix, see details. 23 | } 24 | \item{M}{ 25 | Specification of the means (M) vector, see details. 26 | } 27 | \item{manNames}{ 28 | Character vector of the manifest names. 29 | } 30 | \item{latNames}{ 31 | Character vector of the latent names. 32 | } 33 | \item{Names}{ 34 | Character vector containing all names. Defaults to \code{c(manNames,latNames)}. 35 | } 36 | \item{ObsCovs}{ 37 | Observed covariancem matrix. 38 | } 39 | \item{ImpCovs}{ 40 | Implied covariancem matrix. 41 | } 42 | \item{modelLabels}{ 43 | Logical. If \code{TRUE} all latents are named \code{l1, l2, ...} and all manifests \code{m1, m2, ...} 44 | } 45 | } 46 | \details{ 47 | The matrices can be assigned in various ways, depending on the amount of information that should be stored in the resulting model. 48 | 49 | 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. 50 | 51 | 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): 52 | \describe{ 53 | \item{\code{est}}{Parameter estimates} 54 | \item{\code{std}}{standardized parameter estimates} 55 | \item{\code{par}}{Parameter numbers. 0 indicating fixed variables and parameters with the same parameter number are constrained to be equal.} 56 | \item{\code{fixed}}{Logical matrix indicating if the parameter is fixed.} 57 | } 58 | 59 | 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. 60 | 61 | The number of variables is extracted from the assigned matrices. 62 | } 63 | \value{ 64 | A 'semPlotModel' object. 65 | } 66 | \references{ 67 | 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. 68 | } 69 | \author{ 70 | Sacha Epskamp 71 | } 72 | 73 | 74 | \seealso{ 75 | \code{\link{semPlotModel}} 76 | \code{\link{semCors}} 77 | \code{\link{semPaths}} 78 | \code{\link{lisrelModel}} 79 | } 80 | 81 | -------------------------------------------------------------------------------- /man/regsemplot.Rd: -------------------------------------------------------------------------------- 1 | \name{regsem} 2 | \alias{semPlotModel.regsem} 3 | \title{ 4 | Bridge between regsem output and sempaths 5 | } 6 | \description{ 7 | 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. 8 | } 9 | \usage{ 10 | \method{semPlotModel}{regsem}(object,\dots) 11 | } 12 | %- maybe also 'usage' for other objects documented here. 13 | \arguments{ 14 | \item{object}{ 15 | The regsem output 16 | } 17 | \item{\dots}{Arguments sent to 'lisrelModel', not used in other methods.} 18 | } 19 | 20 | 21 | \value{ 22 | A 'semPlotModel' object. 23 | } 24 | \references{ 25 | Jacobucci, R. (2017). regsem: Regularized Structural Equation Modeling. arXiv preprint arXiv:1703.08489. 26 | } 27 | \author{ 28 | Sacha Epskamp 29 | Myrthe Veenman 30 | Jason Nak 31 | } 32 | 33 | \seealso{ 34 | \code{\link{semPlotModel}} 35 | \code{\link{semPaths}} 36 | } 37 | 38 | \examples{ 39 | 40 | \dontrun{ 41 | ## Example of fitting and plotting a regsem model in semPaths 42 | library(psych) 43 | library(lavaan) 44 | library(regsem) 45 | 46 | # use a subset of the BFI 47 | bfi2 <- bfi[1:250,c(1:5,18,22)] 48 | bfi2[,1] <- reverse.code(-1,bfi2[,1]) 49 | 50 | # specify a SEM model 51 | mod <- " 52 | f1 =~ NA*A1+A2+A3+A4+A5+O2+N3 53 | f1~~1*f1 54 | " 55 | 56 | # fit the model 57 | fit <- cfa(mod, bfi2) 58 | out.reg <- regsem(fit, type="lasso", pars_pen=c(1:7)) 59 | 60 | # plot the model 61 | semPaths(semPlotModel.regsem(object = out.reg)) 62 | } 63 | } -------------------------------------------------------------------------------- /man/semCors.Rd: -------------------------------------------------------------------------------- 1 | \name{semCors} 2 | \alias{semCors} 3 | 4 | \title{ 5 | Visually inspect implied and observed correlations 6 | } 7 | \description{ 8 | This function is still in devellopment. 9 | } 10 | \usage{ 11 | semCors(object, include, vertical = TRUE, titles = FALSE, layout, maximum, ...) 12 | } 13 | %- maybe also 'usage' for other objects documented here. 14 | \arguments{ 15 | \item{object}{ 16 | A \code{semPlotModel} object 17 | } 18 | \item{include}{ 19 | What to include? Can be \code{"observed"}, \code{"implied"} or \code{"difference"}, or a vector containing both. Defaults to showing observed and implied covariances. 20 | } 21 | \item{vertical}{ 22 | Should the layout be vertical or horizontal? 23 | } 24 | \item{titles}{ 25 | Logical, should titles indicating the group and observed/implied correlations be plotted? 26 | } 27 | \item{layout}{ 28 | An optional layout matrix send to \code{\link[qgraph]{qgraph}}. 29 | } 30 | \item{maximum}{ 31 | 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. 32 | } 33 | \item{\dots}{ 34 | Arguments sent to \code{\link[qgraph]{qgraph}} 35 | } 36 | } 37 | 38 | \author{ 39 | Sacha Epskamp 40 | } 41 | -------------------------------------------------------------------------------- /man/semMatrixAlgebra.Rd: -------------------------------------------------------------------------------- 1 | \name{semMatrixAlgebra} 2 | \alias{semMatrixAlgebra} 3 | %- Also NEED an '\alias' for EACH other topic documented here. 4 | \title{ 5 | Extract or calculate with model matrices 6 | } 7 | \description{ 8 | 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. 9 | 10 | If the model is not specified it is attempted to be identified by the given algebra. 11 | } 12 | \usage{ 13 | semMatrixAlgebra(object, algebra, group, simplify = TRUE, model, endoOnly = FALSE) 14 | } 15 | %- maybe also 'usage' for other objects documented here. 16 | \arguments{ 17 | \item{object}{ 18 | 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. 19 | } 20 | \item{algebra}{ 21 | An R expression to use. 22 | } 23 | \item{group}{ 24 | Groups the algebra should be used on. If more than one a list is returned with the result for each group. 25 | } 26 | \item{simplify}{ 27 | If TRUE and only one group is used, return output as is instead of in a list. 28 | } 29 | \item{model}{ 30 | Model to be used in \code{\link{modelMatrices}}, \code{"mplus"}, \code{"ram"} or \code{"lisrel"} 31 | } 32 | \item{endoOnly}{ 33 | Only needed when the model is \code{"lisrel"}, sets all variables to endogenous. 34 | } 35 | } 36 | \details{ 37 | 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}. 38 | 39 | 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}. 40 | 41 | The \code{"ram"} model uses the following matrix names: \code{F}, \code{A} and \code{S}. 42 | } 43 | \value{ 44 | A list containing output per group 45 | } 46 | \author{ 47 | Sacha Epskamp 48 | } 49 | 50 | \seealso{ 51 | \code{\link{semPlotModel}} 52 | \code{\link{semPlotModel-class}} 53 | \code{\link{modelMatrices}} 54 | \code{\link{lisrelModel}} 55 | \code{\link{ramModel}} 56 | } 57 | 58 | \examples{ 59 | ## Mplus user guide SEM example: 60 | outfile <- tempfile(fileext=".out") 61 | tryres <- try({ 62 | download.file("http://www.statmodel.com/usersguide/chap5/ex5.11.html",outfile) 63 | }) 64 | 65 | if (!is(tryres,"try-error")){ 66 | # Plot model: 67 | semPaths(outfile,intercepts=FALSE) 68 | 69 | # Obtain latent regressions (mplus) 70 | semMatrixAlgebra(outfile, Beta) 71 | 72 | # mplus model implied covariance: 73 | mat1 <- semMatrixAlgebra(outfile, 74 | Lambda \%*\% Imin(Beta, TRUE) \%*\% Psi \%*\% t(Imin(Beta, TRUE)) \%*\% t(Lambda) + Theta) 75 | 76 | # Lisrel model implied covariance: 77 | mat2 <- semMatrixAlgebra(outfile, 78 | LY \%*\% Imin(BE, TRUE) \%*\% PS \%*\% t(Imin(BE, TRUE)) \%*\% t(LY) + TE, endoOnly = TRUE) 79 | 80 | # RAM model implied covariance: 81 | mat3 <- semMatrixAlgebra(outfile, 82 | F \%*\% Imin(A,TRUE) \%*\% S \%*\% t(Imin(A, TRUE)) \%*\% t(F)) 83 | 84 | \dontrun{ 85 | # Plot: 86 | library("qgraph") 87 | 88 | pdf("Models.pdf",width=15,height=5) 89 | layout(t(1:3)) 90 | qgraph(round(cov2cor(mat1),5), maximum=1, edge.labels=TRUE, layout = "spring", 91 | cut = 0.4, minimum = 0.1) 92 | title("Mplus model") 93 | qgraph(round(cov2cor(mat2),5), maximum=1, edge.labels=TRUE, layout = "spring", 94 | cut = 0.4, minimum = 0.1) 95 | title("LISREL model") 96 | qgraph(round(cov2cor(mat3),5), maximum=1, edge.labels=TRUE, layout = "spring", 97 | cut = 0.4, minimum = 0.1) 98 | title("RAM model") 99 | dev.off() 100 | } 101 | # They are the same. 102 | } 103 | } 104 | -------------------------------------------------------------------------------- /man/semPlot-package.Rd: -------------------------------------------------------------------------------- 1 | \name{semPlot-package} 2 | \alias{semPlot-package} 3 | \alias{semPlot} 4 | \docType{package} 5 | \title{ 6 | semPlot 7 | } 8 | \description{ 9 | 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}}. 10 | 11 | For plotting the graphs the \code{\link[qgraph]{qgraph}} package is used. 12 | } 13 | 14 | \author{ 15 | Sacha Epskamp (mail@sachaepskamp.com) 16 | 17 | Maintainer: Sacha Epskamp 18 | } 19 | \references{ 20 | github.com/SachaEpskamp/semPlot 21 | } 22 | 23 | \keyword{ package } -------------------------------------------------------------------------------- /man/semPlotModel-class.Rd: -------------------------------------------------------------------------------- 1 | \name{semPlotModel-class} 2 | \Rdversion{1.1} 3 | \docType{class} 4 | \alias{semPlotModel-class} 5 | 6 | \title{Class \code{"semPlotModel"}} 7 | \description{ 8 | 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. 9 | } 10 | \section{Objects from the Class}{ 11 | Objects can be created by calls of the form \code{new("semPlotModel", ...)}. 12 | %% ~~ describe objects here ~~ 13 | } 14 | 15 | 16 | \section{Slots}{ 17 | \describe{ 18 | \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: 19 | \describe{ 20 | \item{\code{label}}{The name of the parameter, used as edge label in the graph.} 21 | \item{\code{lhs}}{Name of the variable on the left hand side of the path.} 22 | \item{\code{edge}}{String as indicator of the edge. This can be one of the following: 23 | \describe{ 24 | \item{\code{->}}{Factor loading} 25 | \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.} 26 | \item{\code{<->}}{(co)variance} 27 | \item{\code{int}}{intercept, The left hand side should be "" and the right hand side indicates the variable to which the intercept belongs.} 28 | \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)} 29 | 30 | }} 31 | 32 | \item{\code{rhs}}{Name of the variable on the left hand side of the path.} 33 | \item{\code{est}}{Parameter estimate.} 34 | \item{\code{est}}{Standardized parameter estimate.} 35 | \item{\code{group}}{Character of the name of the group the parameter belongs to.} 36 | \item{\code{fixed}}{Logical indicating if the parameter is fixed.} 37 | \item{\code{par}}{Parameter number. 0 indicates the parameter is fixed and parameters with the same parameter number are constrained to be equal.} 38 | \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.} 39 | 40 | } 41 | } 42 | \item{\code{Vars}:}{Object of class \code{"data.frame"} indicating the variables used in the SEM model. Must have the following elements: 43 | \describe{ 44 | \item{name}{Name of the variable} 45 | \item{manifest}{Logical indicating if the variable is manifest} 46 | \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. 47 | 48 | }} 49 | \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'}.} 50 | 51 | \item{\code{Computed}:}{Object of class \code{"logical"} indicating if the SEM model was computed or if the object only indicates a structure.} 52 | \item{\code{ObsCovs}:}{Object of class \code{"list"} containing observed covariance matrices for each group. If available.} 53 | \item{\code{ImpCovs}:}{Object of class \code{"list"} containing implied covariance matrices for each group. If available.} 54 | \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.) } 55 | } 56 | } 57 | 58 | 59 | \section{Methods}{ 60 | No methods defined with class "semPlotModel" in the signature. 61 | } 62 | 63 | \author{ 64 | Sacha Epskamp 65 | } 66 | 67 | 68 | %% ~Make other sections like Warning with \section{Warning }{....} ~ 69 | 70 | \seealso{ 71 | \code{\link{semPlotModel}} 72 | \code{\link{semPaths}} 73 | \code{\link{semCors}} 74 | \code{\link{semSyntax}} 75 | \code{\link{semPlotModel-edit}} 76 | } 77 | \examples{ 78 | showClass("semPlotModel") 79 | } 80 | \keyword{classes} 81 | -------------------------------------------------------------------------------- /man/semPlotModel.Rd: -------------------------------------------------------------------------------- 1 | \name{semPlotModel} 2 | \alias{semPlotModel} 3 | \alias{semPlotModel.default} 4 | \alias{semPlotModel.lm} 5 | \alias{semPlotModel.principal} 6 | \alias{semPlotModel.princomp} 7 | \alias{semPlotModel.loadings} 8 | \alias{semPlotModel.factanal} 9 | % \alias{semPlotModel.lavaan} 10 | \alias{semPlotModel.lisrel} 11 | % \alias{semPlotModel.semspec} 12 | \alias{semPlotModel.mplus.model} 13 | \alias{semPlotModel.sem} 14 | \alias{semPlotModel.msem} 15 | \alias{semPlotModel.msemObjectiveML} 16 | \alias{semPlotModel_Amos} 17 | \alias{semPlotModel_Onyx} 18 | \alias{semPlotModel_lavaanModel} 19 | \title{ 20 | SEM model representation 21 | } 22 | \description{ 23 | Methods to read a SEM object and return a \code{\link{semPlotModel-class}} object. 24 | } 25 | \usage{ 26 | \method{semPlotModel}{default}(object, \dots) 27 | \method{semPlotModel}{lm}(object, \dots) 28 | \method{semPlotModel}{principal}(object, \dots) 29 | \method{semPlotModel}{princomp}(object, \dots) 30 | \method{semPlotModel}{loadings}(object, \dots) 31 | \method{semPlotModel}{factanal}(object, \dots) 32 | % \method{semPlotModel}{lavaan}(object) 33 | \method{semPlotModel}{lisrel}(object, \dots) 34 | % \method{semPlotModel}{semspec}(object) 35 | \method{semPlotModel}{mplus.model}(object, mplusStd = c("std", "stdy", "stdyx"), \dots) 36 | \method{semPlotModel}{sem}(object, \dots) 37 | \method{semPlotModel}{msem}(object, \dots) 38 | \method{semPlotModel}{msemObjectiveML}(object, \dots) 39 | semPlotModel_Amos(object) 40 | semPlotModel_Onyx(object) 41 | semPlotModel_lavaanModel(object, ...) 42 | } 43 | %- maybe also 'usage' for other objects documented here. 44 | \arguments{ 45 | \item{object}{ 46 | 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. 47 | } 48 | \item{mplusStd}{ 49 | What standardization to use in Mplus models? 50 | } 51 | \item{model}{ 52 | The original sem model (used in cvregsem) 53 | } 54 | \item{\dots}{Arguments sent to 'lisrelModel', not used in other methods.} 55 | } 56 | \details{ 57 | A detailed overview of which packages are supported and what is supported for each of them will soon be on my website. 58 | } 59 | \value{ 60 | A \code{"semPlotModel"} object. See \code{link{semPlotModel-class}} 61 | } 62 | 63 | \author{ 64 | Sacha Epskamp 65 | } 66 | 67 | \seealso{ 68 | \code{\link{semPaths}} 69 | \code{\link{semCors}} 70 | \code{\link{semPlotModel-class}} 71 | } 72 | -------------------------------------------------------------------------------- /man/semPlotModel.S4-methods.Rd: -------------------------------------------------------------------------------- 1 | \name{semPlotModel_S4-methods} 2 | \docType{methods} 3 | \alias{semPlotModel_S4-methods} 4 | \alias{semPlotModel_S4,lavaan-method} 5 | \alias{semPlotModel_S4} 6 | \title{ S4 methods for semPlotModel } 7 | \description{ 8 | 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. 9 | } 10 | \section{Methods}{ 11 | \describe{ 12 | 13 | \item{\code{signature(object = "lavaan")}}{ 14 | A \code{\link[lavaan]{lavaan-class}} object. 15 | } 16 | }} 17 | \keyword{methods} 18 | -------------------------------------------------------------------------------- /man/semSyntax.Rd: -------------------------------------------------------------------------------- 1 | \name{semSyntax} 2 | \alias{semSyntax} 3 | 4 | \title{ 5 | Produce model syntax for various SEM software 6 | } 7 | \description{ 8 | 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. 9 | 10 | Currently only the R packages 'lavaan' (Rosseel, 2012) and 'sem' (Fox, Nie & Byrnes, 2012) are supported. 11 | } 12 | \usage{ 13 | semSyntax(object, syntax = "lavaan", allFixed = FALSE, file) 14 | } 15 | %- maybe also 'usage' for other objects documented here. 16 | \arguments{ 17 | \item{object}{ 18 | A "semPlotModel" object or any of the input possibilities for \code{\link{semPlotModel}}. 19 | } 20 | \item{syntax}{ 21 | A string indicating which syntax to be used for the output. Currently supported are \code{'lavaan'} and \code{'sem'}. 22 | } 23 | \item{allFixed}{ 24 | Logical, should all parameters be fixed to their estimate. Useful for simulating data. 25 | } 26 | \item{file}{ 27 | Path of a file the model should be written to. 28 | } 29 | } 30 | \value{ 31 | A string containing the \code{lavaan} model syntax or a \code{"semmod"} object for the \code{sem} package. 32 | } 33 | \references{ 34 | Yves Rosseel (2012). lavaan: An R Package for Structural 35 | Equation Modeling. Journal of Statistical Software, 48(2), 36 | 1-36. URL http://www.jstatsoft.org/v48/i02/. 37 | 38 | John Fox, Zhenghua Nie and Jarrett Byrnes (2012). sem: 39 | Structural Equation Models. R package version 3.0-0. 40 | http://CRAN.R-project.org/package=sem 41 | } 42 | \author{ 43 | Sacha Epskamp 44 | } 45 | 46 | \seealso{ 47 | \code{\link{semPlotModel}} 48 | \code{\link{semPlotModel-class}} 49 | \code{\link{semPaths}} 50 | } 51 | 52 | \examples{ 53 | # MIMIC model, example 5.8 from mplus user guide: 54 | tryres <- try({ 55 | Data <- read.table("http://www.statmodel.com/usersguide/chap5/ex5.8.dat") 56 | }) 57 | 58 | if (!is(tryres,"try-error")){ 59 | 60 | 61 | names(Data) <- c(paste("y", 1:6, sep=""), 62 | paste("x", 1:3, sep="")) 63 | 64 | # Data <- Data[,c(7:9,1:6)] 65 | 66 | # Model: 67 | model.Lavaan <- 'f1 =~ y1 + y2 + y3 68 | f2 =~ y4 + y5 + y6 69 | f1 + f2 ~ x1 + x2 + x3 ' 70 | 71 | # Run Lavaan: 72 | library("lavaan") 73 | fit.Lavaan <- lavaan:::cfa(model.Lavaan, data=Data, std.lv=TRUE) 74 | 75 | # Obtain Lavaan syntax: 76 | model.Lavaan2 <- semSyntax(fit.Lavaan, "lavaan") 77 | 78 | # Run Lavaan again: 79 | fit.Lavaan2 <- lavaan:::lavaan(model.Lavaan2, data=Data) 80 | 81 | # Compare models: 82 | layout(t(1:2)) 83 | semPaths(fit.Lavaan,"std",title=FALSE) 84 | title("Lavaan model 1",line=3) 85 | semPaths(fit.Lavaan2, "std",title=FALSE) 86 | title("Lavaan model 2",line=3) 87 | 88 | # Convert to sem model: 89 | model.sem <- semSyntax(fit.Lavaan, "sem") 90 | 91 | # Run sem: 92 | library("sem") 93 | fit.sem <- sem:::sem(model.sem, data = Data) 94 | 95 | # Compare models: 96 | layout(t(1:2)) 97 | semPaths(fit.Lavaan,"std",title=FALSE) 98 | title("Lavaan",line=3) 99 | semPaths(fit.sem, "std",title=FALSE) 100 | title("sem",line=3) 101 | } 102 | } 103 | -------------------------------------------------------------------------------- /man/tricks.Rd: -------------------------------------------------------------------------------- 1 | \name{semPlot-tricks} 2 | \alias{+.semPlotModel} 3 | \alias{semPlotModel.list} 4 | \title{ 5 | Tricks that can be used in semPlot. 6 | } 7 | \description{ 8 | 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. 9 | } 10 | \usage{ 11 | \method{+}{semPlotModel}(x,y) 12 | \method{semPlotModel}{list}(object, \dots) 13 | } 14 | %- maybe also 'usage' for other objects documented here. 15 | \arguments{ 16 | \item{x}{ 17 | A \code{"semPlotModel"} object 18 | } 19 | \item{y}{ 20 | A \code{"semPlotModel"} object 21 | } 22 | \item{object}{ 23 | 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. 24 | } 25 | \item{\dots}{ 26 | Not used. 27 | } 28 | } 29 | \author{ 30 | Sacha Epskamp 31 | } 32 | \seealso{ 33 | \code{\link{semPlotModel}} 34 | \code{\link{semPaths}} 35 | \code{\link{semCors}} 36 | } 37 | 38 | 39 | \examples{ 40 | # A silly dataset: 41 | A <- rnorm(100) 42 | B <- A + rnorm(100) 43 | C <- B + rnorm(100) 44 | DF <- data.frame(A,B,C) 45 | 46 | # Two regressions: 47 | res1 <- lm(B ~ C, data = DF) 48 | res2 <- lm(A ~ B + C, data = DF) 49 | 50 | # Plot both in the same path diagram in two ways: 51 | semPaths(res1 + res2, "model", "est", intercepts=FALSE) 52 | semPaths(list(res1,res2), "model", "est", intercepts=FALSE) 53 | } --------------------------------------------------------------------------------