Starting changes to LISREL to type='LISREL' and to expectations for mxEval(model...
[openmx:openmx.git] / R / MxExpectationLISREL.R
1 #
2 #   Copyright 2007-2013 The OpenMx Project
3 #
4 #   Licensed under the Apache License, Version 2.0 (the "License");
5 #   you may not use this file except in compliance with the License.
6 #   You may obtain a copy of the License at
7
8 #        http://www.apache.org/licenses/LICENSE-2.0
9
10 #   Unless required by applicable law or agreed to in writing, software
11 #   distributed under the License is distributed on an "AS IS" BASIS,
12 #   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13 #   See the License for the specific language governing permissions and
14 #   limitations under the License.
15
16 #--------------------------------------------------------------------
17 # Author: Michael D. Hunter
18 # Filename: MxLISRELObjective.R
19 #--------------------------------------------------------------------
20
21 #--------------------------------------------------------------------
22 # Revision History
23 #   Mon Feb 20 13:03:21 Central Standard Time 2012 -- Michael Hunter added means
24 #   Sat Apr 07 19:48:33 Central Daylight Time 2012 -- Michael Hunter added lots of error checking
25
26
27
28 #--------------------------------------------------------------------
29 # **DONE**
30 setClass(Class = "MxExpectationLISREL",
31         representation = representation(
32                 LX = "MxCharOrNumber",
33                 LY = "MxCharOrNumber",
34                 BE = "MxCharOrNumber",
35                 GA = "MxCharOrNumber",
36                 PH = "MxCharOrNumber",
37                 PS = "MxCharOrNumber",
38                 TD = "MxCharOrNumber",
39                 TE = "MxCharOrNumber",
40                 TH = "MxCharOrNumber",
41                 TX = "MxCharOrNumber",
42                 TY = "MxCharOrNumber",
43                 KA = "MxCharOrNumber",
44                 AL = "MxCharOrNumber",
45                 thresholds = "MxCharOrNumber",
46                 dims = "character",
47                 definitionVars = "list",
48                 dataColumns = "numeric", #Used in FIML to grab the correct data elements
49                 thresholdColumns = "numeric", #Used in FIML
50                 thresholdLevels = "numeric", # Used in FIML
51                 threshnames = "character",
52                 depth = "integer"), #Used to speed up I-A inverse in RAM, could be used to speed up I-B inverse in LISREL
53         contains = "MxBaseExpectation")
54
55
56 #--------------------------------------------------------------------
57 # **DONE**
58 setMethod("initialize", "MxExpectationLISREL",
59         function(.Object, LX, LY, BE, GA, PH, PS, TD, TE, TH, TX, TY, KA, AL, dims, thresholds, threshnames,
60                 data = as.integer(NA), name = 'expectation') {
61                 .Object@name <- name
62                 .Object@LX <- LX
63                 .Object@LY <- LY
64                 .Object@BE <- BE
65                 .Object@GA <- GA
66                 .Object@PH <- PH
67                 .Object@PS <- PS
68                 .Object@TD <- TD
69                 .Object@TE <- TE
70                 .Object@TH <- TH
71                 .Object@TX <- TX
72                 .Object@TY <- TY
73                 .Object@KA <- KA
74                 .Object@AL <- AL
75                 .Object@data <- data
76                 .Object@dims <- dims
77                 .Object@thresholds <- thresholds
78                 .Object@definitionVars <- list()
79                 return(.Object)
80         }
81 )
82
83
84 #--------------------------------------------------------------------
85 setMethod("genericExpConvertEntities", "MxExpectationLISREL",
86         function(.Object, flatModel, namespace, labelsData) {
87                 if(is.na(.Object@data)) {
88                         modelname <- getModelName(.Object)
89                         msg <- paste("The LISREL expectation function",
90                                 "does not have a dataset associated with it in model",
91                                 omxQuotes(modelname))
92                         stop(msg, call.=FALSE)
93                 }
94 #               The code below is out of date.  See current MxRAMObjective for up to date info.
95 #               pair <- updateRAMdimnames(.Object, job, flatJob, model@name)
96 #               job <- pair[[1]]
97 #               flatJob <- pair[[2]]
98 #               if (flatJob@datasets[[.Object@data]]@type != 'raw') {
99 #                       if (.Object@vector) {
100 #                               msg <- paste("The RAM objective",
101 #                                       "in model", omxQuotes(model@name), "has specified",
102 #                                       "'vector' = TRUE, but the observed data is not raw data")
103 #                               stop(msg, call.=FALSE)
104 #                       }
105 #                       job@.newobjects <- FALSE
106 #                       job@.newobjective <- FALSE
107 #                       job@.newtree <- FALSE
108 #                       return(list(job, flatJob))
109 #               }
110 #               if (is.na(.Object@M) || is.null(job[[.Object@M]])) {
111 #                       msg <- paste("The RAM objective",
112 #                               "has raw data but is missing",
113 #                               "an expected means vector in model",
114 #                               omxQuotes(model@name))
115 #                       stop(msg, call.=FALSE)
116 #               }
117 #               pair <- updateThresholdDimnames(.Object, job, flatJob, model@name)
118 #               job <- pair[[1]]
119 #               flatJob <- pair[[2]]
120                 return(flatModel)
121         }
122 )
123
124
125 #--------------------------------------------------------------------
126 # **DONE**
127 setMethod("qualifyNames", signature("MxExpectationLISREL"), 
128         function(.Object, modelname, namespace) {
129                 .Object@name <- imxIdentifier(modelname, .Object@name)
130                 .Object@LX <- imxConvertIdentifier(.Object@LX, modelname, namespace)
131                 .Object@LY <- imxConvertIdentifier(.Object@LY, modelname, namespace)
132                 .Object@BE <- imxConvertIdentifier(.Object@BE, modelname, namespace)
133                 .Object@GA <- imxConvertIdentifier(.Object@GA, modelname, namespace)
134                 .Object@PH <- imxConvertIdentifier(.Object@PH, modelname, namespace)
135                 .Object@PS <- imxConvertIdentifier(.Object@PS, modelname, namespace)
136                 .Object@TD <- imxConvertIdentifier(.Object@TD, modelname, namespace)
137                 .Object@TE <- imxConvertIdentifier(.Object@TE, modelname, namespace)
138                 .Object@TH <- imxConvertIdentifier(.Object@TH, modelname, namespace)
139                 .Object@TX <- imxConvertIdentifier(.Object@TX, modelname, namespace)
140                 .Object@TY <- imxConvertIdentifier(.Object@TY, modelname, namespace)
141                 .Object@KA <- imxConvertIdentifier(.Object@KA, modelname, namespace)
142                 .Object@AL <- imxConvertIdentifier(.Object@AL, modelname, namespace)
143                 .Object@data <- imxConvertIdentifier(.Object@data, modelname, namespace)
144                 .Object@thresholds <- sapply(.Object@thresholds, imxConvertIdentifier, modelname, namespace)
145                 return(.Object)
146         }
147 )
148
149
150 #--------------------------------------------------------------------
151 # Helper functions used in genericObjFunConvert method
152
153 checkLISRELmeansHelper <- function(Lam, Mean, Latent, matrixname, lamname, modelname){
154         if(Latent){
155                 varType <- "latent" #used in error messages
156                 checkInd <- 2  #used to check row or col names match (1 for rows, 2 for cols)
157                 checkStg <- "col"
158         }
159         else{
160                 varType <- "manifest"
161                 checkInd <- 1
162                 checkStg <- "row"
163         }
164         # Check that the means are non-null
165         if(is.null(Mean)){
166                 msg <- paste("The LISREL expectation function",
167                         "has an observed means vector but",
168                         "is missing expected means vector",
169                         "for", varType, "variables",
170                         matrixname,  "in model",
171                         omxQuotes(modelname))
172                 stop(msg, call. = FALSE)
173         }
174         # Check that the means have dimnames
175         meanDimnames <- dimnames(Mean)
176         if(is.null(meanDimnames)){
177                 msg <- paste("The", matrixname, "matrix associated",
178                 "with the LISREL expectation function in model", 
179                 omxQuotes(modelname), "does not contain dimnames.")
180                 stop(msg, call. = FALSE)        
181         }
182         #Check if means are a column vector
183         meanRownames <- meanDimnames[[1]]
184         meanColnames <- meanDimnames[[2]]
185         if (!is.null(meanColnames) && length(meanColnames) > 1) {
186                 msg <- paste("The", matrixname, "matrix associated",
187                 "with the LISREL expectation function in model", 
188                 omxQuotes(modelname), "is not an N x 1 matrix.")
189                 stop(msg, call. = FALSE)
190         }
191         #Check if means exactly match Lambda matrix (including order)
192         if (!identical(dimnames(Lam)[[checkInd]], meanRownames)) {
193                 msg <- paste("The", checkStg, "names of the", lamname, "matrix",
194                         "and the row names of the", matrixname, "matrix",
195                         "in model", 
196                         omxQuotes(modelname), "do not contain identical",
197                         "names.")
198                 stop(msg, call. = FALSE)
199         }
200 }
201
202
203 checkLISRELmeans <- function(Lam, ManMean, LatMean, X, modelname){
204         if(X){
205                 manMeanMat <- 'TX'
206                 latMeanMat <- 'KA'
207                 lamMat <- 'LX'
208         } else{
209                 manMeanMat <- 'TY'
210                 latMeanMat <- 'AL'
211                 lamMat <- 'LY'
212         }
213         checkLISRELmeansHelper(
214                 Lam=Lam,
215                 Mean=ManMean,
216                 Latent=FALSE,
217                 matrixname=manMeanMat,
218                 lamname= lamMat,
219                 modelname=modelname
220         )
221         checkLISRELmeansHelper(
222                 Lam=Lam,
223                 Mean=LatMean,
224                 Latent=TRUE,
225                 matrixname=latMeanMat,
226                 lamname= lamMat,
227                 modelname=modelname
228         )
229 }
230
231
232 #--------------------------------------------------------------------
233 # **DONE**
234 # Note: Lots of error checking is done in this method
235 setMethod("genericExpFunConvert", signature("MxExpectationLISREL"), 
236         function(.Object, flatModel, model, labelsData, defVars, dependencies) {
237                 modelname <- imxReverseIdentifier(model, .Object@name)[[1]]     
238                 name <- .Object@name
239                 lxMatrix <- .Object@LX
240                 lyMatrix <- .Object@LY
241                 beMatrix <- .Object@BE
242                 gaMatrix <- .Object@GA
243                 phMatrix <- .Object@PH
244                 psMatrix <- .Object@PS
245                 tdMatrix <- .Object@TD
246                 teMatrix <- .Object@TE
247                 thMatrix <- .Object@TH
248                 txMatrix <- .Object@TX
249                 tyMatrix <- .Object@TY
250                 kaMatrix <- .Object@KA
251                 alMatrix <- .Object@AL
252                 data <- .Object@data
253                 beMatrix2 <- beMatrix #This is a placeholder for use with the I-BE inverse speedup
254                 # Check if the model has data
255                 if(is.na(data)) {
256                         msg <- paste("The LISREL expectation function",
257                                 "does not have a dataset associated with it in model",
258                                 omxQuotes(modelname))
259                         stop(msg, call. = FALSE)
260                 }
261                 #
262                 # if any of the names of TX, TY, KA, AL are not missing
263                 #        then the model must have observed means or raw data
264                 mxDataObject <- flatModel@datasets[[.Object@data]]
265                 if(single.na(mxDataObject@means) && mxDataObject@type != "raw") {
266                         if(!is.na(txMatrix)) {
267                                 msg <- paste("The LISREL expectation function",
268                                         "has an expected means vector, TX, but",
269                                         "no observed means vector in model",
270                                         omxQuotes(modelname))
271                                 stop(msg, call. = FALSE)
272                         }
273                         if(!is.na(tyMatrix)) {
274                                 msg <- paste("The LISREL expectation function",
275                                         "has an expected means vector, TY, but",
276                                         "no observed means vector in model",
277                                         omxQuotes(modelname))
278                                 stop(msg, call. = FALSE)
279                         }
280                         if(!is.na(kaMatrix)) {
281                                 msg <- paste("The LISREL expectation function",
282                                         "has an expected means vector, KA, but",
283                                         "no observed means vector in model",
284                                         omxQuotes(modelname))
285                                 stop(msg, call. = FALSE)
286                         }
287                         if(!is.na(alMatrix)) {
288                                 msg <- paste("The LISREL expectation function",
289                                         "has an expected means vector, AL, but",
290                                         "no observed means vector in model",
291                                         omxQuotes(modelname))
292                                 stop(msg, call. = FALSE)
293                         }
294                 }
295                 checkNumericData(mxDataObject)
296                 .Object@LX <- imxLocateIndex(flatModel, lxMatrix, name)
297                 .Object@LY <- imxLocateIndex(flatModel, lyMatrix, name)
298                 .Object@BE <- imxLocateIndex(flatModel, beMatrix, name)
299                 .Object@GA <- imxLocateIndex(flatModel, gaMatrix, name)
300                 .Object@PH <- imxLocateIndex(flatModel, phMatrix, name)
301                 .Object@PS <- imxLocateIndex(flatModel, psMatrix, name)
302                 .Object@TD <- imxLocateIndex(flatModel, tdMatrix, name)
303                 .Object@TE <- imxLocateIndex(flatModel, teMatrix, name)
304                 .Object@TH <- imxLocateIndex(flatModel, thMatrix, name)
305                 .Object@TX <- imxLocateIndex(flatModel, txMatrix, name)
306                 .Object@TY <- imxLocateIndex(flatModel, tyMatrix, name)
307                 .Object@KA <- imxLocateIndex(flatModel, kaMatrix, name)
308                 .Object@AL <- imxLocateIndex(flatModel, alMatrix, name)
309                 .Object@data <- as.integer(imxLocateIndex(flatModel, data, name))
310                 
311                 #
312                 # Check the data has row and column names as appropriate
313                 verifyObservedNames(mxDataObject@observed, mxDataObject@means, mxDataObject@type, flatModel, modelname, "LISREL")
314                 #
315                 # Change *Matrix from the string name of the matrix to the object
316                 lxMatrix <- flatModel[[lxMatrix]]
317                 lyMatrix <- flatModel[[lyMatrix]]
318                 beMatrix <- flatModel[[beMatrix]]
319                 gaMatrix <- flatModel[[gaMatrix]]
320                 phMatrix <- flatModel[[phMatrix]]
321                 psMatrix <- flatModel[[psMatrix]]
322                 tdMatrix <- flatModel[[tdMatrix]]
323                 teMatrix <- flatModel[[teMatrix]]
324                 thMatrix <- flatModel[[thMatrix]]
325                 txMatrix <- flatModel[[txMatrix]]
326                 tyMatrix <- flatModel[[tyMatrix]]
327                 kaMatrix <- flatModel[[kaMatrix]]
328                 alMatrix <- flatModel[[alMatrix]]
329                 #
330                 # if LY is not null, then
331                 #        check LY for dimnames and
332                 #        check its means (TY, AL) and
333                 #        check for TE, BE, PS
334                 if(!is.null(lyMatrix)){
335                         # Check LY for dimnames
336                         if (is.null(dimnames(lyMatrix))) {
337                                 msg <- paste("The LY matrix of model",
338                                         omxQuotes(modelname), "does not contain dimnames")
339                                 stop(msg, call. = FALSE)
340                         }
341                         if (is.null(dimnames(lyMatrix)[[2]])) {
342                                 msg <- paste("The LY matrix of model",
343                                         omxQuotes(modelname), "does not contain colnames")
344                                 stop(msg, call. = FALSE)
345                         }
346                         # Check its means (TY, AL) 
347                         if(!single.na(mxDataObject@means) || mxDataObject@type == "raw") {
348                                 checkLISRELmeans(
349                                         Lam=lyMatrix,
350                                         ManMean=tyMatrix,
351                                         LatMean=alMatrix,
352                                         X=FALSE,
353                                         modelname=modelname
354                                 )
355                         }
356                         # Check for TE, BE, PS
357                         if(is.null(teMatrix)){
358                                 msg <- paste("The TE matrix is absent but the LY",
359                                         "matrix is present in model",
360                                         omxQuotes(modelname))
361                                 stop(msg, call. = FALSE)
362                         }
363                         if(is.null(beMatrix)){
364                                 msg <- paste("The BE matrix is absent but the LY",
365                                         "matrix is present in model",
366                                         omxQuotes(modelname))
367                                 stop(msg, call. = FALSE)
368                         }
369                         if(is.null(psMatrix)){
370                                 msg <- paste("The PS matrix is absent but the LY",
371                                         "matrix is present in model",
372                                         omxQuotes(modelname))
373                                 stop(msg, call. = FALSE)
374                         }
375                 }
376                 #
377                 # if LX is non-null, then
378                 #        check LX for dimnames
379                 #        check its means (TX, KA) and
380                 #        check for TD, PH
381                 if(!is.null(lxMatrix)){
382                         # Check LX for dimnames
383                         if (is.null(dimnames(lxMatrix))) {
384                                 msg <- paste("The LX matrix of model",
385                                         omxQuotes(modelname), "does not contain dimnames")
386                                 stop(msg, call. = FALSE)
387                         }
388                         if (is.null(dimnames(lxMatrix)[[2]])) {
389                                 msg <- paste("The LX matrix of model",
390                                         omxQuotes(modelname), "does not contain colnames")
391                                 stop(msg, call. = FALSE)
392                         }
393                         # Check its means (TX, KA)
394                         if(!single.na(mxDataObject@means) || mxDataObject@type == "raw") {
395                                 checkLISRELmeans(
396                                         Lam=lxMatrix,
397                                         ManMean=txMatrix,
398                                         LatMean=kaMatrix,
399                                         X=TRUE,
400                                         modelname=modelname
401                                 )
402                         }
403                         # Check for TD, PH
404                         if(is.null(tdMatrix)){
405                                 msg <- paste("The TD matrix is absent but the LX",
406                                         "matrix is present in model",
407                                         omxQuotes(modelname))
408                                 stop(msg, call. = FALSE)
409                         }
410                         if(is.null(phMatrix)){
411                                 msg <- paste("The PH matrix is absent but the LX",
412                                         "matrix is present in model",
413                                         omxQuotes(modelname))
414                                 stop(msg, call. = FALSE)
415                         }
416                 }
417                 #
418                 # if both LX and LY are not null
419                 #        must have TH, GA
420                 if(!is.null(lxMatrix) && !is.null(lyMatrix)){
421                         if(is.null(thMatrix)){
422                                 msg <- paste("The TH matrix is absent but the LY and LX",
423                                         "matrices are present in model",
424                                         omxQuotes(modelname))
425                                 stop(msg, call. = FALSE)
426                         }
427                         if(is.null(gaMatrix)){
428                                 msg <- paste("The GA matrix is absent but the LY and LX",
429                                         "matrices are present in model",
430                                         omxQuotes(modelname))
431                                 stop(msg, call. = FALSE)
432                         }
433                 }
434                 if(is.null(lxMatrix) && (!is.null(phMatrix) || !is.null(tdMatrix))) {
435                         msg <- paste("Some, but not all of measurement and structural matrices are missing.",
436                                 "The LX matrix is absent but the PH or TD",
437                                 "matrices are present in model",
438                                 omxQuotes(modelname))
439                         stop(msg, call. = FALSE)
440                 }
441                 if(is.null(lyMatrix) && (!is.null(psMatrix) || !is.null(teMatrix) || !is.null(beMatrix))) {
442                         msg <- paste("Some, but not all of measurement and structural matrices are missing.",
443                                 "The LY matrix is absent but at least one of the PS, TE, and BE",
444                                 "matrices are present in model",
445                                 omxQuotes(modelname))
446                         stop(msg, call. = FALSE)
447                 }
448                 # TODO Add check for if it has at least one of LX or LY
449                 #
450                 # Raw data error checking
451                 #  Set the canonical order of observed variable names.
452                 translatedNames <- c(dimnames(lyMatrix)[[1]], dimnames(lxMatrix)[[1]]) #fMatrixTranslateNames(fMatrix, modelname) #Rearrange the rownames of F to match the order of the columns
453                 .Object@depth <- generateLISRELDepth(flatModel, beMatrix2, model@options) #Find out how many iterations of I + BE + BE^2 + ... are need until nilpotency.
454                 if (mxDataObject@type == 'raw') {
455                         threshName <- .Object@thresholds
456                         checkNumberOrdinalColumns(mxDataObject)
457                         .Object@definitionVars <- imxFilterDefinitionVariables(defVars, data)
458                         .Object@dataColumns <- generateDataColumns(flatModel, translatedNames, data)
459                         verifyThresholds(flatModel, model, labelsData, data, translatedNames, threshName)
460                         .Object@thresholds <- imxLocateIndex(flatModel, threshName, name)
461                         retval <- generateThresholdColumns(flatModel, model, labelsData, translatedNames, data, threshName)
462                         .Object@thresholdColumns <- retval[[1]]
463                         .Object@thresholdLevels <- retval[[2]]
464                         if (length(mxDataObject@observed) == 0) {
465                                 .Object@data <- as.integer(NA)
466                         }
467                         if (single.na(.Object@dims)) {
468                                 .Object@dims <- translatedNames
469                         }
470                 } else {# Non-Raw data checking
471                         .Object@thresholds <- as.integer(NA)
472                         # Check the observed covariance matrix is separated into endo and exo blocks
473                         if (!identical(translatedNames, rownames(mxDataObject@observed))) {
474                                 msg <- paste("The names of the manifest",
475                                         "variables in the LY and LX matrices of model",
476                                         omxQuotes(modelname), "do not match the",
477                                         "dimnames of the observed covariance matrix",
478                                         "or they are in the wrong order.")
479                                 stop(msg, call. = FALSE)
480                         }
481                 }
482                 return(.Object)
483         }
484 )
485
486
487 #--------------------------------------------------------------------
488 # **DONE**
489 setMethod("genericExpDependencies", signature("MxExpectationLISREL"),
490         function(.Object, dependencies) {
491         sources <- c(.Object@LX, .Object@LY, .Object@BE, .Object@GA, 
492                 .Object@PH, .Object@PS, .Object@TD, .Object@TE, 
493                 .Object@TH, .Object@TX, .Object@TY, .Object@KA, 
494                 .Object@AL, .Object@thresholds)
495         sources <- sources[!is.na(sources)]
496         dependencies <- imxAddDependency(sources, .Object@name, dependencies)
497         return(dependencies)
498         }
499 )
500
501
502 #--------------------------------------------------------------------
503 # **DONE**
504 setMethod("genericExpRename", signature("MxExpectationLISREL"),
505         function(.Object, oldname, newname) {
506                 .Object@LX <- renameReference(.Object@LX, oldname, newname)
507                 .Object@LY <- renameReference(.Object@LY, oldname, newname)
508                 .Object@BE <- renameReference(.Object@BE, oldname, newname)
509                 .Object@GA <- renameReference(.Object@GA, oldname, newname)
510                 .Object@PH <- renameReference(.Object@PH, oldname, newname)
511                 .Object@PS <- renameReference(.Object@PS, oldname, newname)
512                 .Object@TD <- renameReference(.Object@TD, oldname, newname)
513                 .Object@TE <- renameReference(.Object@TE, oldname, newname)
514                 .Object@TH <- renameReference(.Object@TH, oldname, newname)
515                 .Object@TX <- renameReference(.Object@TX, oldname, newname)
516                 .Object@TY <- renameReference(.Object@TY, oldname, newname)
517                 .Object@KA <- renameReference(.Object@KA, oldname, newname)
518                 .Object@AL <- renameReference(.Object@AL, oldname, newname)
519                 .Object@data <- renameReference(.Object@data, oldname, newname)
520                 .Object@thresholds <- sapply(.Object@thresholds, renameReference, oldname, newname)             
521                 return(.Object)
522         }
523 )
524
525
526 #--------------------------------------------------------------------
527 checkLISRELargument <- function(x, xname) {
528         if (!(single.na(x) || typeof(x) == "character")) {
529                 msg <- paste("argument ", xname, " is not a string ",
530                         "(the name of the '", xname, "' matrix)", sep="")
531                 stop(msg)
532         }
533         if (is.na(x)) x <- as.integer(NA)
534         return(x)
535 }
536
537
538 #--------------------------------------------------------------------
539 # **DONE**
540 imxExpectationLISREL <- function(LX=NA, LY=NA, BE=NA, GA=NA, PH=NA, PS=NA, TD=NA, TE=NA, TH=NA, TX = NA, TY = NA, KA = NA, AL = NA, dimnames = NA, thresholds = NA, threshnames = dimnames) {
541         LX <- checkLISRELargument(LX, "LX")
542         LY <- checkLISRELargument(LY, "LY")
543         BE <- checkLISRELargument(BE, "BE")
544         GA <- checkLISRELargument(GA, "GA")
545         PH <- checkLISRELargument(PH, "PH")
546         PS <- checkLISRELargument(PS, "PS")
547         TD <- checkLISRELargument(TD, "TD")
548         TE <- checkLISRELargument(TE, "TE")
549         TH <- checkLISRELargument(TH, "TH")
550         TX <- checkLISRELargument(TX, "TX")
551         TY <- checkLISRELargument(TY, "TY")
552         KA <- checkLISRELargument(KA, "KA")
553         AL <- checkLISRELargument(AL, "AL")
554         
555         if (single.na(thresholds)) thresholds <- as.character(NA)
556         if (single.na(dimnames)) dimnames <- as.character(NA)
557         if (single.na(threshnames)) threshnames <- as.character(NA)
558         if (!is.vector(dimnames) || typeof(dimnames) != 'character') {
559                 stop("Dimnames argument is not a character vector")
560         }
561         if (!is.vector(threshnames) || typeof(threshnames) != 'character') {
562                 stop("'threshnames' argument is not a character vector")
563         }
564         if (length(thresholds) != 1) {
565                 stop("Thresholds argument must be a single matrix or algebra name")
566         }
567         if (length(dimnames) == 0) {
568                 stop("Dimnames argument cannot be an empty vector")
569         }
570         if (length(threshnames) == 0) {
571                 stop("'threshnames' argument cannot be an empty vector")
572         }
573         if (length(dimnames) > 1 && any(is.na(dimnames))) {
574                 stop("NA values are not allowed for dimnames vector")
575         }
576         if (length(threshnames) > 1 && any(is.na(threshnames))) {
577                 stop("NA values are not allowed for 'threshnames' vector")
578         }
579         return(new("MxExpectationLISREL", LX, LY, BE, GA, PH, PS, TD, TE, TH, TX, TY, KA, AL, dimnames, thresholds, threshnames))
580 }
581
582
583 #--------------------------------------------------------------------
584 # **DONE**
585 displayExpectationLISREL <- function(expectation) {
586         cat("MxExpectationLISREL", omxQuotes(expectation@name), '\n')
587         cat("@LX :", omxQuotes(expectation@LX), '\n')
588         cat("@LY :", omxQuotes(expectation@LY), '\n')
589         cat("@BE :", omxQuotes(expectation@BE), '\n')
590         cat("@GA :", omxQuotes(expectation@GA), '\n')
591         cat("@PH :", omxQuotes(expectation@PH), '\n')
592         cat("@PS :", omxQuotes(expectation@PS), '\n')
593         cat("@TD :", omxQuotes(expectation@TD), '\n')
594         cat("@TE :", omxQuotes(expectation@TE), '\n')
595         cat("@TH :", omxQuotes(expectation@TH), '\n')
596         if (is.na(expectation@TX)) {
597                 cat("@TX :", expectation@TX, '\n')
598         } else {
599                 cat("@TX :", omxQuotes(expectation@TX), '\n')
600         }
601         if (is.na(expectation@TY)) {
602                 cat("@TY :", expectation@TY, '\n')
603         } else {
604                 cat("@TY :", omxQuotes(expectation@TY), '\n')
605         }
606         if (is.na(expectation@KA)) {
607                 cat("@KA :", expectation@KA, '\n')
608         } else {
609                 cat("@KA :", omxQuotes(expectation@KA), '\n')
610         }
611         if (is.na(expectation@AL)) {
612                 cat("@AL :", expectation@AL, '\n')
613         } else {
614                 cat("@AL :", omxQuotes(expectation@AL), '\n')
615         }
616         if (single.na(expectation@dims)) {
617                 cat("@dims : NA \n")
618         } else {
619                 cat("@dims :", omxQuotes(expectation@dims), '\n')
620         }               
621         if (single.na(expectation@thresholds)) {
622                 cat("@thresholds : NA \n")
623         } else {
624                 cat("@thresholds :", omxQuotes(expectation@thresholds), '\n')
625         }
626         invisible(expectation)
627 }
628
629
630 #--------------------------------------------------------------------
631 # **DONE**
632 setMethod("print", "MxExpectationLISREL", function(x,...) { 
633         displayExpectationLISREL(x) 
634 })
635
636
637 #--------------------------------------------------------------------
638 # **DONE**
639 setMethod("show", "MxExpectationLISREL", function(object) { 
640         displayExpectationLISREL(object) 
641 })
642
643
644
645
646
647 #------------------------------------------------------------------------------
648 #------------------------------------------------------------------------------
649 #------------------------------------------------------------------------------
650 #------------------------------------------------------------------------------
651 #------------------------------------------------------------------------------
652 # BEGIN SECTION OF THINGS I DO NOT THINK I NEED
653
654
655
656 #setMethod("genericObjInitialMatrix", "MxRAMObjective",
657 #       function(.Object, flatModel) {
658 #               flatObjective <- flatModel@objectives[[.Object@name]]
659 #               if (flatObjective@vector == FALSE) {
660 #                       return(matrix(as.double(NA), 1, 1))
661 #               } else {
662 #                       modelname <- imxReverseIdentifier(flatModel, flatObjective@name)[[1]]
663 #                       name <- flatObjective@name
664 #                       if(is.na(flatObjective@data)) {
665 #                               msg <- paste("The RAM objective",
666 #                               "does not have a dataset associated with it in model",
667 #                               omxQuotes(modelname))
668 #                               stop(msg, call. = FALSE)
669 #                       }
670 #                       mxDataObject <- flatModel@datasets[[flatObjective@data]]
671 #                       if (mxDataObject@type != 'raw') {
672 #                               msg <- paste("The dataset associated with the RAM objective", 
673 #                                       "in model", omxQuotes(modelname), "is not raw data.")
674 #                               stop(msg, call. = FALSE)
675 #                       }
676 #                       rows <- nrow(mxDataObject@observed)
677 #                       return(matrix(as.double(NA), rows, 1))
678 #               }
679 #})
680 #
681 #
682 #
683 #
684 generateLISRELDepth <- function(flatModel, aMatrixName, modeloptions) {
685         mxObject <- flatModel[[aMatrixName]]
686         if (!is(mxObject, "MxMatrix")) {
687                 return(as.integer(NA))
688         }
689         if (identical(modeloptions[['RAM Inverse Optimization']], "No")) {
690                 return(as.integer(NA))
691         }
692         if (is.null(modeloptions[['RAM Inverse Optimization']]) &&
693                 identical(getOption('mxOptions')[['RAM Inverse Optimization']], "No")) {
694                 return(as.integer(NA))
695         }       
696         maxdepth <- modeloptions[['RAM Max Depth']]
697         if (is.null(maxdepth) || (length(maxdepth) != 1) ||
698                 is.na(maxdepth) || !is.numeric(maxdepth) || maxdepth < 0) {
699                 maxdepth <- nrow(mxObject) - 1
700         }
701         return(omxGetLISRELDepth(mxObject, maxdepth))
702 }
703
704 omxGetLISRELDepth <- function(A, maxdepth = nrow(A) - 1) {
705         mxObject <- A
706         aValues <- matrix(0, nrow(mxObject), ncol(mxObject))
707         defvars <- apply(mxObject@labels, c(1,2), imxIsDefinitionVariable)
708         squarebrackets <- apply(mxObject@labels, c(1,2), hasSquareBrackets)
709         aValues[mxObject@free] <- 1
710         aValues[mxObject@values != 0] <- 1
711         aValues[defvars] <- 1
712         aValues[squarebrackets] <- 1
713         return(generateDepthHelper(aValues, aValues, 0, maxdepth))
714 }
715
716 generateDepthHelper <- function(aValues, currentProduct, depth, maxdepth) {
717         if (depth > maxdepth) {
718                 return(as.integer(NA))
719         }
720         if (all(currentProduct == 0)) { 
721                 return(as.integer(depth))
722         } else {
723                 return(generateDepthHelper(aValues, currentProduct %*% aValues, depth + 1, maxdepth))
724         }
725 }
726 #
727 #fMatrixTranslateNames <- function(fMatrix, modelName) {
728 #       retval <- character()
729 #       colNames <- dimnames(fMatrix)[[2]]
730 #       for(i in 1:nrow(fMatrix)) {
731 #               irow <- fMatrix[i,]
732 #               matches <- which(irow == 1)
733 #               if (length(matches) != 1) {
734 #                       err <- paste("The model",
735 #                               omxQuotes(modelName), "does not contain",
736 #                               "a valid F matrix")
737 #                       stop(err, call. = FALSE)
738 #               }
739 #               retval[[i]] <- colNames[[matches[[1]]]]
740 #       }
741 #       return(retval)
742 #}
743 #
744 #updateRAMdimnames <- function(flatObjective, job, flatJob, modelname) {
745 #       fMatrixName <- flatObjective@F
746 #       mMatrixName <- flatObjective@M
747 #       if (is.na(mMatrixName)) {
748 #               mMatrix <- NA
749 #       } else {
750 #               mMatrix <- job[[mMatrixName]]
751 #       }
752 #       fMatrix <- job[[fMatrixName]]
753 #       if (is.null(fMatrix)) {
754 #               stop(paste("Unknown F matrix name", 
755 #                       omxQuotes(simplifyName(fMatrixName, modelname)),
756 #                       "detected in the objective function",
757 #                       "of model", omxQuotes(modelname)), call. = FALSE)
758 #       }
759 #       dims <- flatObjective@dims
760 #       if (!is.null(dimnames(fMatrix)) && !single.na(dims) && 
761 #               !identical(dimnames(fMatrix)[[2]], dims)) {
762 #               msg <- paste("The F matrix associated",
763 #                       "with the RAM objective in model", 
764 #                       omxQuotes(modelname), "contains dimnames and",
765 #                       "the objective function has specified dimnames")
766 #               stop(msg, call.=FALSE)          
767 #       }
768 #       if (is.null(dimnames(fMatrix)) && !single.na(dims)) {
769 #               fMatrixFlat <- flatJob[[fMatrixName]]
770 #               dimnames(fMatrix) <- list(c(), dims)
771 #               dimnames(fMatrixFlat) <- list(c(), dims)
772 #               job[[fMatrixName]] <- fMatrix
773 #               flatJob[[fMatrixName]] <- fMatrixFlat
774 #       }
775 #       if (!isS4(mMatrix) && (is.null(mMatrix) || is.na(mMatrix))) return(list(job, flatJob))
776 #       if (!is.null(dimnames(mMatrix)) && !single.na(dims) &&
777 #               !identical(dimnames(mMatrix), list(NULL, dims))) {
778 #               msg <- paste("The M matrix associated",
779 #                       "with the RAM objective in model", 
780 #                       omxQuotes(modelname), "contains dimnames and",
781 #                       "the objective function has specified dimnames")
782 #               stop(msg, call.=FALSE)  
783 #       }
784 #       if (is.null(dimnames(mMatrix)) && !single.na(dims)) {
785 #               mMatrixFlat <- flatJob[[mMatrixName]]
786 #               dimnames(mMatrix) <- list(NULL, dims)
787 #               dimnames(mMatrixFlat) <- list(NULL, dims)
788 #               job[[mMatrixName]] <- mMatrix
789 #               flatJob[[mMatrixName]] <- mMatrixFlat
790 #       }
791 #       return(list(job, flatJob))
792 #}
793 # END SECTION OF THINGS I DO NO THINK I NEED