Preparation for type='LISREL' models. manifest and latent
[openmx:openmx.git] / R / MxRAMModel.R
1 #
2 #   Copyright 2007-2012 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 setClass(Class = "MxRAMModel",
17         representation = representation(),
18         contains = "MxModel")
19
20 imxModelTypes[['RAM']] <- "MxRAMModel"
21
22 imxVariableTypes <- c(imxVariableTypes, "exogenous", "endogenous")
23
24 # Define generic functions
25
26 setMethod("imxTypeName", "MxRAMModel", 
27         function(model) { "RAM" }
28 )
29
30 setMethod("imxInitModel", "MxRAMModel", 
31         function(model) {
32                 if (is.null(model[['A']])) {
33                         model[['A']] <- createMatrixA(model)
34                 }
35                 if (is.null(model[['S']])) {
36                         model[['S']] <- createMatrixS(model)
37                 }
38                 if (is.null(model[['objective']])) {
39                         model[['objective']] <- mxRAMObjective('A', 'S', 'F')
40                 }
41                 model[['F']] <- createMatrixF(model)
42                 return(model)
43         }
44 )
45
46 setMethod("imxModelBuilder", "MxRAMModel", 
47         function(model, lst, name, 
48                 manifestVars, latentVars, remove, independent) {
49                 model <- variablesArgumentRAM(model, manifestVars, latentVars, remove)
50                 model <- listArgumentRAM(model, lst, remove)
51                 notPathOrData <- getNotPathsOrData(lst)
52                 callNextMethod(model, notPathOrData, name, character(), 
53                         character(), remove, independent)
54         }
55 )
56
57 setMethod("imxVerifyModel", "MxRAMModel",
58         function(model) {
59                 if ((length(model$A) == 0) ||
60                         (length(model$S) == 0) ||
61                         (length(model$F) == 0)) {
62                                 msg <- paste("The RAM model", omxQuotes(model@name),
63                 "does not contain any paths.")
64                                 stop(msg, call. = FALSE)
65                 }
66                 objective <- model$objective
67                 if (!is.null(objective) && is(objective, "MxRAMObjective")) {
68                         if (!is.null(model@data) && model@data@type == "raw" &&
69                 is.null(model$M)) {
70                                 msg <- paste("The RAM model", omxQuotes(model@name),
71                        "contains raw data but has not specified any means paths.")
72                                 stop(msg, call. = FALSE)
73                         }
74                         if (!is.null(model@data) && !single.na(model@data@means) &&
75                                 is.null(model$M)) {
76                                 msg <- paste("The RAM model", omxQuotes(model@name),
77                                         "contains an observed means vector",
78                                         "but has not specified any means paths.")
79                                 stop(msg, call. = FALSE)                
80                         }
81                 }
82                 if (length(model@submodels) > 0) {
83                         return(all(sapply(model@submodels, imxVerifyModel)))
84                 }
85                 return(TRUE)
86         }
87 )
88
89
90 setReplaceMethod("[[", "MxRAMModel",
91         function(x, i, j, value) {
92                 return(replaceMethodRAM(x, i, value))
93         }
94 )
95
96 setReplaceMethod("$", "MxRAMModel",
97         function(x, name, value) {
98                 return(replaceMethodRAM(x, name, value))
99         }
100 )
101
102 # Helper functions used by the generic functions
103
104 variablesArgumentRAM <- function(model, manifestVars, latentVars, remove) {
105         if (single.na(manifestVars)) {
106                 manifestVars <- character()
107         }
108         if (single.na(latentVars)) {
109                 latentVars <- character()
110         }
111         if (remove == TRUE) {
112                 if (length(latentVars) + length(manifestVars) > 0) {
113                         model <- removeVariablesRAM(model, latentVars, manifestVars)
114                 }
115         } else if (length(manifestVars) + length(latentVars) > 0) {
116                 latentVars <- varsToCharacter(latentVars, "latent")
117                 manifestVars <- varsToCharacter(manifestVars, "manifest")
118                 checkVariables(model, latentVars, manifestVars)
119                 model <- addVariablesRAM(model, latentVars, manifestVars)
120         }
121         return(model)
122 }
123
124 removeVariablesRAM <- function(model, latent, manifest) {
125         missingLatent <- setdiff(latent, model@latentVars)
126         missingManifest <- setdiff(manifest, model@manifestVars)
127         if (length(missingLatent) > 0) {
128                 stop(paste("The latent variable(s)", omxQuotes(missingLatent),
129                         "are not present in the model.",
130                         "They cannot be deleted"), call. = FALSE)
131         } else if (length(missingManifest) > 0) {
132                 stop(paste("The manifest variable(s)", omxQuotes(missingManifest),
133                         "are not present in the model.",
134                         "They cannot be deleted"), call. = FALSE)
135         } else if (length(unique(latent)) != length(latent)) {
136                 stop("The latent variables list contains duplicate elements",
137                         call. = FALSE)
138         } else if (length(unique(manifest)) != length(manifest)) {
139                 stop("The manifest variables list contains duplicate elements",
140                         call. = FALSE)
141         }
142         model@latentVars <- setdiff(model@latentVars, latent)
143         model@manifestVars <- setdiff(model@manifestVars, manifest)
144         A <- model[['A']]
145         S <- model[['S']]
146         A <- removeVariablesAS(A, latent)
147         A <- removeVariablesAS(A, manifest)
148         S <- removeVariablesAS(S, latent)
149         S <- removeVariablesAS(S, manifest)
150         model[['F']] <- createMatrixF(model)
151         model[['A']] <- A
152         model[['S']] <- S
153         return(model)
154 }
155
156 addVariablesRAM <- function(model, latent, manifest) {
157
158         modelLatent   <- unlist(model@latentVars, use.names = FALSE)
159         modelManifest <- unlist(model@manifestVars, use.names = FALSE)
160
161         model <- addVariablesHelper(model, "latentVars", latent)
162         model <- addVariablesHelper(model, "manifestVars", manifest)
163
164         latent <- unlist(latent, use.names = FALSE)
165         manifest <- unlist(manifest, use.names = FALSE)
166
167         newLatent   <- setdiff(latent, modelLatent)
168         newManifest <- setdiff(manifest, modelManifest)
169
170         A <- model[['A']]
171         S <- model[['S']]
172         M <- model[['M']]
173         if (is.null(A)) {
174                 A <- createMatrixA(model)
175         } else {
176                 A <- addVariablesAS(A, model, newLatent, newManifest)
177         }
178         if (is.null(S)) {
179                 S <- createMatrixS(model)
180         } else {
181                 S <- addVariablesAS(S, model, newLatent, newManifest)
182         }
183         if (!is.null(M)) {
184                 M <- addVariablesM(M, model, newLatent, newManifest)
185         }
186         model[['A']] <- A
187         model[['S']] <- S
188         model[['M']] <- M
189         model[['F']] <- createMatrixF(model)
190         return(model)
191 }
192
193
194 listArgumentRAM <- function(model, lst, remove) {
195         if(remove == TRUE) {
196                 model <- removeEntriesRAM(model, lst)
197         } else {
198                 model <- addEntriesRAM(model, lst)
199         }
200         return(model)
201 }
202
203 addEntriesRAM <- function(model, entries) {
204         if (length(entries) == 0) {
205                 return(model)
206         }
207         filter <- sapply(entries, is, "MxPath")
208         paths <- entries[filter]
209         if (length(paths) > 0) {
210                 model <- insertAllPathsRAM(model, paths)
211         }
212         filter <- sapply(entries, is, "MxData")
213         data <- entries[filter]
214         if (length(data) > 0) {
215                 if (length(data) > 1) {
216                         warning("Multiple data sources specified.  Only one will be chosen.")
217                 }
218                 data <- data[[1]]
219                 model@data <- data
220                 model[['F']] <- createMatrixF(model)
221         }
222         return(model)
223 }
224
225 requireMeansVector <- function(data) {
226         return(!is.null(data) && ((data@type == 'raw') ||
227                 ((data@type == 'cov' || data@type == 'cor') &&
228                  !(length(data@means) == 1 && is.na(data@means)))))
229 }
230
231 removeEntriesRAM <- function(model, entries) {
232         if (length(entries) == 0) {
233                 return(model)
234         }
235         filter <- sapply(entries, is, "MxPath")
236         paths <- entries[filter]
237         if (length(paths) > 0) {
238                 model <- removeAllPathsRAM(model, paths)
239         }
240         return(model)
241 }
242
243 getNotPathsOrData <- function(lst) {
244         if (length(lst) == 0) {
245                 return(lst)
246         }
247         pathfilter <- sapply(lst, is, "MxPath")
248         datafilter <- sapply(lst, is, "MxData")
249         retval <- lst[!(pathfilter | datafilter)]
250         return(retval)
251 }
252
253 checkPaths <- function(model, paths) {
254         variables <- c(model@manifestVars, model@latentVars)
255         fromNames <- unlist(sapply(paths, slot, 'from'))
256         toNames <- unlist(sapply(paths, slot, 'to'))
257         if(is.null(fromNames)) { fromNames <- character() }
258         if(is.null(toNames)) { toNames <- character() }
259         if (any(is.na(fromNames)) || any(is.na(toNames))) {
260                 stop("The \'from\' field or the \'to\' field contains an NA", call. = FALSE)
261         }
262         missingSource <- setdiff(fromNames, variables)
263         missingSink   <- setdiff(toNames, variables)
264         missingSource <- setdiff(missingSource, "one")
265         if(length(missingSource) > 0) {
266                 stop(paste("The following are neither manifest nor latent variables:",
267                         omxQuotes(missingSource)), call. = FALSE)
268         }
269         if(length(missingSink) > 0) {
270                 stop(paste("The following are neither manifest nor latent variables:",
271                         omxQuotes(missingSink)), call. = FALSE)
272         }
273 }
274
275 objectiveIsMissingMeans <- function(model) {
276         objective <- model@objective
277         return(!is.null(objective) &&
278                 is(objective, "MxRAMObjective") &&
279                 is.na(objective@M))
280 }
281
282 insertAllPathsRAM <- function(model, paths) {
283         A <- model[['A']]
284         S <- model[['S']]
285         M <- model[['M']]
286         if (is.null(A)) { A <- createMatrixA(model) }
287         if (is.null(S)) { S <- createMatrixS(model) }
288         for(i in 1:length(paths)) {
289                 path <- paths[[i]]
290         
291                 missingvalues <- is.na(path@values)
292                 path@values[missingvalues] <- 0
293                 
294                 if (single.na(path@to)) {
295                         path@to <- path@from
296                         paths[[i]] <- path
297                 }
298                 
299                 if (length(path@from) == 1 && (path@from == "one")) {
300                         if (is.null(M)) {
301                                 M <- createMatrixM(model) 
302                                 if(objectiveIsMissingMeans(model)) {
303                                         model@objective@M <- "M"
304                                 }
305                         }
306                         M <- insertMeansPathRAM(path, M)
307                 } else {
308                         bivariate <- FALSE
309                         self      <- FALSE
310                         # interpret 'path@connect' argument
311                         if ((path@connect == "unique.pairs" ) || (path@connect == "unique.bivariate")){
312                                 bivariate <- TRUE
313                         }
314                         if ((path@connect == "all.bivariate") || (path@connect == "unique.bivariate")){
315                                 self <- TRUE
316                         }
317                         
318                         # if path@connect!="single", expand from and to
319                         if ((path@connect != "single")){ 
320                                 path@from <- rep(path@from, each=length(path@to))
321                                 path@to   <- rep(path@to, length(path@from)/length(path@to))
322
323                                 exclude <- rep(FALSE, length(path@from))
324
325                                 # if 'excluderedundant', then exclude b,a if a,b is present
326                                 if (bivariate){
327                                         sortedPairs <- t(apply(matrix(c(path@from, path@to), ncol = 2), 1, sort))
328                                         exclude <- exclude | duplicated(sortedPairs)
329                                 }
330
331                                 # if 'excludeself', then exclude x,x paths
332                                 if (self){
333                                         exclude <- exclude | (path@from==path@to)
334                                 }
335                                 path@from <- path@from[!exclude]
336                                 path@to   <- path@to[!exclude]
337                                 
338                         }
339                         retval <- insertPathRAM(path, A, S)
340                         A <- retval[[1]]
341                         S <- retval[[2]]        
342                 }
343         }
344         checkPaths(model, paths)
345         model[['A']] <- A
346         model[['S']] <- S
347         if (!is.null(M)) {
348                 model[['M']] <- M
349         }
350         
351         return(model)
352 }
353
354 removeAllPathsRAM <- function(model, paths) {
355         A <- model[['A']]
356         S <- model[['S']]
357         M <- model[['M']]
358         if (is.null(A)) { A <- createMatrixA(model) }
359         if (is.null(S)) { S <- createMatrixS(model) }
360         for(i in 1:length(paths)) {
361
362                 path <- paths[[i]]
363
364                 if (single.na(path@to)) {
365                         path@to <- path@from
366                         paths[[i]] <- path
367                 }
368                 
369                 if (length(path@from) == 1 && (path@from == "one")) {           
370                         M <- removeMeansPathRAM(path, M)
371                 } else {
372                         if ((path@connect != "single")) { 
373                                 bivariate <- FALSE
374                                 self      <- FALSE
375                                 if ((path@connect == "unique.pairs" ) || (path@connect == "unique.bivariate")){
376                                         bivariate <- TRUE
377                                 }
378                                 if ((path@connect == "all.bivariate") || (path@connect == "unique.bivariate")){
379                                         self <- TRUE
380                                 }
381                                 path@from <- rep(path@from, each=length(path@to))
382                                 path@to   <- rep(path@to, length(path@from)/length(path@to))
383
384                                 exclude <- rep(FALSE, length(path@from))
385
386                                 # if 'excluderedundant', then exclude b,a if a,b is present
387                                 if (bivariate){
388                                         sortedPairs <- t(apply(matrix(c(path@from, path@to), ncol = 2), 1, sort))
389                                         exclude <- exclude | duplicated(sortedPairs)
390                                 }
391                                 # if 'excludeself', then exclude x,x paths
392                                 if (self){
393                                         exclude <- exclude | (path@from==path@to)
394                                 }
395                                 path@from <- path@from[!exclude]
396                                 path@to   <- path@to[!exclude]
397                                 
398                         }
399                         retval <- removePathRAM(path, A, S)
400                         A <- retval[[1]]
401                         S <- retval[[2]]
402                 }
403         }
404         checkPaths(model, paths)
405         model[['A']] <- A
406         model[['S']] <- S
407         if (!is.null(M)) {
408                 model[['M']] <- M
409         }
410         return(model)
411 }
412
413
414 insertPathRAM <- function(path, A, S) {
415         allfrom <- path@from
416         allto <- path@to
417         allarrows <- path@arrows
418         allfree <- path@free
419         allvalues <- path@values
420         alllabels <- path@labels
421         alllbound <- path@lbound
422         allubound <- path@ubound
423         maxlength <- max(length(allfrom), length(allto))
424         A_free <- A@free
425         A_values <- A@values
426         A_labels <- A@labels
427         A_lbound <- A@lbound
428         A_ubound <- A@ubound
429         S_free   <- S@free
430         S_values <- S@values
431         S_labels <- S@labels
432         S_lbound <- S@lbound
433         S_ubound <- S@ubound
434         for(i in 0:(maxlength - 1)) {
435                 from <- allfrom[[i %% length(allfrom) + 1]]
436                 to <- allto[[i %% length(allto) + 1]]
437                 arrows <- allarrows[[i %% length(allarrows) + 1]]
438                 nextvalue <- allvalues[[i %% length(allvalues) + 1]]
439                 nextfree <- allfree[[i %% length(allfree) + 1]]
440                 nextlabel <- alllabels[[i %% length(alllabels) + 1]]
441                 nextubound <- allubound[[i %% length(allubound) + 1]]
442                 nextlbound <- alllbound[[i %% length(alllbound) + 1]]           
443                 if (arrows == 1) {
444                         A_free[to, from] <- nextfree
445                         A_values[to, from] <- nextvalue
446                         A_labels[to, from] <- nextlabel
447                         A_ubound[to, from] <- nextubound
448                         A_lbound[to, from] <- nextlbound
449                         S_values[to, from] <- 0
450                         S_labels[to, from] <- as.character(NA)
451                         S_free[to, from] <- FALSE
452                         S_values[from, to] <- 0
453                         S_labels[from, to] <- as.character(NA)
454                         S_free[from, to] <- FALSE                       
455                 } else if (arrows == 2) {
456                         S_free[to, from] <- nextfree
457                         S_values[to, from] <- nextvalue
458                         S_labels[to, from] <- nextlabel
459                         S_ubound[to, from] <- nextubound
460                         S_lbound[to, from] <- nextlbound
461                         S_free[from, to] <- nextfree
462                         S_values[from, to] <- nextvalue
463                         S_labels[from, to] <- nextlabel
464                         S_ubound[from, to] <- nextubound
465                         S_lbound[from, to] <- nextlbound
466                         A_values[to, from] <- 0
467                         A_labels[to, from] <- as.character(NA)
468                         A_free[to, from] <- FALSE
469                         A_values[to, from] <- 0
470                         A_labels[to, from] <- as.character(NA)
471                         A_free[to, from] <- FALSE
472                 } else {
473                         stop(paste("Unknown arrow type", arrows, 
474                                         "with source", omxQuotes(from), 
475                                 "and sink", omxQuotes(to)),
476                                 call. = FALSE)
477                 }
478         }
479         A@free <- A_free
480         A@values <-     A_values 
481         A@labels <-     A_labels 
482         A@lbound <-     A_lbound 
483         A@ubound <-     A_ubound 
484         S@free <- S_free   
485         S@values <-     S_values 
486         S@labels <-     S_labels 
487         S@lbound <- S_lbound 
488         S@ubound <- S_ubound 
489         return(list(A, S))
490 }
491
492 removeMeansPathRAM <- function(path, M) {
493         if(is.null(M)) {
494                 return(NULL)
495         }
496         allto <- path@to
497         for(i in 0:(length(allto) - 1)) {
498                 to <- allto[[i %% length(allto) + 1]]
499                 M@free[1, to] <- FALSE
500                 M@values[1, to] <- 0
501                 M@labels[1, to] <- as.character(NA)
502         }
503         return(M)
504 }
505
506 insertMeansPathRAM <- function(path, M) {
507         allto <- path@to
508         arrows <- path@arrows
509         allfree <- path@free
510         allvalues <- path@values
511         alllabels <- path@labels
512         alllbound <- path@lbound
513         allubound <- path@ubound        
514         if (any(arrows != 1)) {
515                 stop(paste('The means path to variable', omxQuotes(to),
516                         'does not contain a single-headed arrow.'), call. = FALSE)
517         }
518         for(i in 0:(length(allto) - 1)) {
519                 to <- allto[[i %% length(allto) + 1]]
520                 nextvalue <- allvalues[[i %% length(allvalues) + 1]]
521                 nextfree <- allfree[[i %% length(allfree) + 1]]
522                 nextlabel <- alllabels[[i %% length(alllabels) + 1]]
523                 nextubound <- allubound[[i %% length(allubound) + 1]]
524                 nextlbound <- alllbound[[i %% length(alllbound) + 1]]
525                 M@free[1, to] <- nextfree
526                 M@values[1, to] <- nextvalue
527                 M@labels[1, to] <- nextlabel
528                 M@ubound[1, to] <- nextubound
529                 M@lbound[1, to] <- nextlbound
530         }
531         return(M)
532 }
533
534 removePathRAM <- function(path, A, S) {
535         allfrom <- path@from
536         allto <- path@to
537         print(path@from)
538         print(path@to)
539         allarrows <- path@arrows
540         maxlength <- max(length(allfrom), length(allto))
541         A_free <- A@free
542         A_values <- A@values
543         A_labels <- A@labels
544         S_free   <- S@free
545         S_values <- S@values
546         S_labels <- S@labels
547         for(i in 0:(maxlength - 1)) {
548                 from <- allfrom[i %% length(allfrom) + 1]
549                 to <- allto[i %% length(allto) + 1]
550                 arrows <- allarrows[i %% length(allarrows) + 1]
551                 if (arrows == 1) {
552                         A_values[to, from] <- 0
553                         A_labels[to, from] <- as.character(NA)
554                         A_free[to, from] <- FALSE               
555                 } else if (arrows == 2) {
556                         S_values[to, from] <- 0
557                         S_labels[to, from] <- as.character(NA)
558                         S_free[to, from] <- FALSE               
559                         S_values[from, to] <- 0
560                         S_labels[from, to] <- as.character(NA)
561                         S_free[from, to] <- FALSE                                       
562                 } else {
563                         stop(paste("Unknown arrow type", arrows, 
564                                         "with source", omxQuotes(from), 
565                                         "and sink", omxQuotes(to)),
566                                         call. = FALSE)
567                 }
568         }
569         A@free <- A_free
570         A@values <-     A_values 
571         A@labels <-     A_labels 
572         S@free <- S_free   
573         S@values <-     S_values 
574         S@labels <-     S_labels        
575         return(list(A, S))
576 }
577
578 createMatrixM <- function(model) {
579         variables <- c(model@manifestVars, model@latentVars)
580         len <- length(variables)
581         names <- list(NULL, variables)
582         values <- matrix(0, 1, len)
583         labels <- matrix(as.character(NA), 1, len)
584         free <- matrix(c(rep.int(FALSE, length(model@manifestVars)),
585                 rep.int(FALSE, length(model@latentVars))), 1, len)
586         retval <- mxMatrix("Full", values = values, free = free, labels = labels, name = "M")
587         dimnames(retval) <- names
588         return(retval)
589 }
590
591 createMatrixA <- function(model) {
592         variables <- c(model@manifestVars, model@latentVars)
593         len <- length(variables)
594         names <- list(variables, variables)
595         values <- matrix(0, len, len)
596         free <- matrix(FALSE, len, len)
597         labels <- matrix(as.character(NA), len, len)
598         retval <- mxMatrix("Full", values = values, free = free, labels = labels, name = "A")
599         dimnames(retval) <- names
600         return(retval)
601 }
602
603 createMatrixS <- function(model) {
604         variables <- c(model@manifestVars, model@latentVars)
605         len <- length(variables)
606         names <- list(variables, variables)
607         values <- matrix(0, len, len)
608         free <- matrix(FALSE, len, len)
609         labels <- matrix(as.character(NA), len, len)
610         retval <- mxMatrix("Symm", values = values, free = free, labels = labels, name = "S")
611         dimnames(retval) <- names
612         return(retval)
613 }
614
615 createMatrixF <- function(model) {
616         variables <- c(model@manifestVars, model@latentVars)
617         len <- length(variables)
618         values <- diag(nrow = length(model@manifestVars), ncol = len)
619         names <- list(model@manifestVars, variables)
620         if (!is.null(model@data) && (model@data@type != 'raw')) {
621                 manifestNames <- rownames(model@data@observed)
622                 extraData <- setdiff(manifestNames, model@manifestVars)
623                 extraVars <- setdiff(model@manifestVars, manifestNames)
624                 if (length(extraData) > 0) {
625                         msg <- paste("The observed data contains the variables:",
626                                 omxQuotes(extraData), "that have not been declared in the",
627                                 "manifest variables.")
628                         stop(msg, call. = FALSE)
629                 }
630                 if (length(extraVars) > 0) {
631                         msg <- paste("The manifest variables include",
632                                 omxQuotes(extraVars), "that have not been found in the",
633                                 "observed data.")
634                         stop(msg, call. = FALSE)
635                 }
636                 dimnames(values) <- names
637                 values <- values[manifestNames,]
638                 names <- list(manifestNames, variables)
639         }
640         free <- matrix(FALSE, length(model@manifestVars), len)
641         labels <- matrix(as.character(NA), length(model@manifestVars), len)
642         retval <- mxMatrix("Full", values = values, free = free, labels = labels, name = "F")
643         dimnames(retval) <- names
644         return(retval)
645 }
646
647 addVariablesAS <- function(oldmatrix, model, newLatent, newManifest) {
648         newLatent <- length(newLatent)
649         newManifest <- length(newManifest)
650         oldmatrix@values <- addVariablesMatrix(oldmatrix@values, 0, 
651                 model, newLatent, newManifest)
652         oldmatrix@free <- addVariablesMatrix(oldmatrix@free, FALSE, 
653                 model, newLatent, newManifest)
654         oldmatrix@labels <- addVariablesMatrix(oldmatrix@labels, as.character(NA), 
655                 model, newLatent, newManifest)
656         oldmatrix@lbound <- addVariablesMatrix(oldmatrix@lbound, as.numeric(NA), 
657                 model, newLatent, newManifest)
658         oldmatrix@ubound <- addVariablesMatrix(oldmatrix@ubound, as.numeric(NA), 
659                 model, newLatent, newManifest)          
660         variables <- c(model@manifestVars, model@latentVars)
661         dimnames(oldmatrix) <- list(variables, variables)
662         return(oldmatrix)
663 }
664
665 addVariablesM <- function(oldmatrix, model, newLatent, newManifest) {
666         oldmatrix@values <- addVariablesMatrixM(oldmatrix@values, 0, 0, model, newLatent, newManifest)
667         oldmatrix@free   <- addVariablesMatrixM(oldmatrix@free, FALSE, TRUE, model, newLatent, newManifest)
668         oldmatrix@labels <- addVariablesMatrixM(oldmatrix@labels, as.character(NA), as.character(NA),
669                 model, newLatent, newManifest) 
670         oldmatrix@lbound <- addVariablesMatrixM(oldmatrix@lbound, as.numeric(NA), as.numeric(NA), 
671                 model, newLatent, newManifest)
672         oldmatrix@ubound <- addVariablesMatrixM(oldmatrix@ubound, as.numeric(NA), as.numeric(NA), 
673                 model, newLatent, newManifest)
674         dimnames(oldmatrix) <- list(NULL, c(model@manifestVars, model@latentVars))
675         return(oldmatrix)
676 }
677
678 removeVariablesAS <- function(oldmatrix, variables) {
679         if (length(variables) > 0) {
680                 for (i in 1:length(variables)) {
681                         index <- match(variables[[i]], dimnames(oldmatrix)[[1]])
682                         oldmatrix@values <- oldmatrix@values[-index, -index]
683                         oldmatrix@free <- oldmatrix@free[-index, -index]
684                         oldmatrix@labels <- oldmatrix@labels[-index, -index]
685                         oldmatrix@lbound <- oldmatrix@lbound[-index, -index]
686                         oldmatrix@ubound <- oldmatrix@ubound[-index, -index]
687                 }
688         }
689         return(oldmatrix)
690 }
691
692
693 addVariablesMatrix <- function(oldmatrix, value, model, newLatent, newManifest) {
694         currentManifest <- length(model@manifestVars) - newManifest
695         currentLatent <- length(model@latentVars) - newLatent
696         newSize <- length(model@manifestVars) + length(model@latentVars)
697         if (currentManifest > 0) {
698                 manifestXmanifest <- oldmatrix[1 : currentManifest, 1 : currentManifest]
699         } else {
700                 manifestXmanifest <- matrix(value, 0, 0)
701         }
702         if (currentLatent > 0) {
703                 latentStart <- currentManifest + 1
704                 latentEnd <- currentManifest + currentLatent
705                 manifestXlatent <- oldmatrix[1 : currentManifest, latentStart : latentEnd]
706                 latentXmanifest <- oldmatrix[latentStart : latentEnd, 1 : currentManifest]
707                 latentXlatent <- oldmatrix[latentStart : latentEnd, latentStart : latentEnd]
708         } else {
709                 manifestXlatent <- matrix(value, 0, 0)
710                 latentXmanifest <- matrix(value, 0, 0)
711                 latentXlatent <- matrix(value, 0, 0)
712         }
713         newtop <- cbind(manifestXmanifest, matrix(value, currentManifest, newManifest),
714                                         manifestXlatent, matrix(value, currentManifest, newLatent)) 
715         newtop <- rbind(newtop, matrix(value, newManifest, newSize))
716         newbottom <- cbind(latentXmanifest, matrix(value, currentLatent, newManifest),
717                                         latentXlatent, matrix(value, currentLatent, newLatent)) 
718         newbottom <- rbind(newbottom, matrix(value, newLatent, newSize))
719         newmatrix <- rbind(newtop, newbottom)
720         return(newmatrix)
721 }
722
723 addVariablesMatrixM <- function(oldmatrix, newLatentValue, newManifestValue, model, newLatent, newManifest) {
724         newManifest <- length(newManifest)
725         newLatent <- length(newLatent)
726         currentManifest <- length(model@manifestVars) - newManifest
727         currentLatent <- length(model@latentVars) - newLatent
728         values <- c(oldmatrix[1, 1:currentManifest], 
729                 rep.int(newManifestValue, newManifest),
730                 oldmatrix[1, (currentManifest + 1) : (currentLatent + currentManifest)],
731                 rep.int(newLatentValue, newLatent))
732         newmatrix <- matrix(values, 1, length(model@manifestVars) + length(model@latentVars))
733         return(newmatrix)
734 }
735
736 replaceMethodRAM <- function(model, index, value) {
737         pair <- imxReverseIdentifier(model, index)
738         namespace <- pair[[1]]
739         name <- pair[[2]]
740         if (namespace == model@name && name == "data") {
741                 model@data <- value
742                 if (requireMeansVector(value)) {
743                         model@objective@M <- "M"
744                 }
745         } else {
746                 model <- imxReplaceMethod(model, index, value)
747         }
748         return(model)
749 }
750