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