Fixing bugs introduced into error checking.
[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         
289         legalVars <- c(model@latentVars, model@manifestVars, "one")
290         
291         for(i in 1:length(paths)) {
292                 path <- paths[[i]]
293         
294                 missingvalues <- is.na(path@values)
295                 path@values[missingvalues] <- 0
296                 
297                 if (single.na(path@to)) {
298                         path@to <- path@from
299                         paths[[i]] <- path
300                 }
301                 
302                 allFromTo <- unique(c(path@from, path@to))
303                 varExist <- allFromTo %in% legalVars 
304                 if(!all(varExist)) {
305                         missingVars <- allFromTo[!varExist]
306                         stop(paste("Nice try, you need to add", 
307                                 omxQuotes(missingVars), 
308                                 "to either manifestVars or LatentVars before you",
309                                 "can use them in a path."), call. = FALSE)
310                 }
311                 
312                 if (length(path@from) == 1 && (path@from == "one")) {
313                         if (is.null(M)) {
314                                 M <- createMatrixM(model) 
315                                 if(objectiveIsMissingMeans(model)) {
316                                         model@objective@M <- "M"
317                                 }
318                         }
319                         M <- insertMeansPathRAM(path, M)
320                 } else {
321                         bivariate <- FALSE
322                         self      <- FALSE
323                         # interpret 'path@connect' argument
324                         if ((path@connect == "unique.pairs" ) || (path@connect == "unique.bivariate")){
325                                 bivariate <- TRUE
326                         }
327                         if ((path@connect == "all.bivariate") || (path@connect == "unique.bivariate")){
328                                 self <- TRUE
329                         }
330                         
331                         # if path@connect!="single", expand from and to
332                         if ((path@connect != "single")){ 
333                                 path@from <- rep(path@from, each=length(path@to))
334                                 path@to   <- rep(path@to, length(path@from)/length(path@to))
335
336                                 exclude <- rep(FALSE, length(path@from))
337
338                                 # if 'excluderedundant', then exclude b,a if a,b is present
339                                 if (bivariate){
340                                         sortedPairs <- t(apply(matrix(c(path@from, path@to), ncol = 2), 1, sort))
341                                         exclude <- exclude | duplicated(sortedPairs)
342                                 }
343
344                                 # if 'excludeself', then exclude x,x paths
345                                 if (self){
346                                         exclude <- exclude | (path@from==path@to)
347                                 }
348                                 path@from <- path@from[!exclude]
349                                 path@to   <- path@to[!exclude]
350                                 
351                         }
352                         retval <- insertPathRAM(path, A, S)
353                         A <- retval[[1]]
354                         S <- retval[[2]]        
355                 }
356         }
357         checkPaths(model, paths)
358         model[['A']] <- A
359         model[['S']] <- S
360         if (!is.null(M)) {
361                 model[['M']] <- M
362         }
363         
364         return(model)
365 }
366
367 removeAllPathsRAM <- function(model, paths) {
368         A <- model[['A']]
369         S <- model[['S']]
370         M <- model[['M']]
371         if (is.null(A)) { A <- createMatrixA(model) }
372         if (is.null(S)) { S <- createMatrixS(model) }
373         for(i in 1:length(paths)) {
374
375                 path <- paths[[i]]
376
377                 if (single.na(path@to)) {
378                         path@to <- path@from
379                         paths[[i]] <- path
380                 }
381                 
382                 if (length(path@from) == 1 && (path@from == "one")) {           
383                         M <- removeMeansPathRAM(path, M)
384                 } else {
385                         if ((path@connect != "single")) { 
386                                 bivariate <- FALSE
387                                 self      <- FALSE
388                                 if ((path@connect == "unique.pairs" ) || (path@connect == "unique.bivariate")){
389                                         bivariate <- TRUE
390                                 }
391                                 if ((path@connect == "all.bivariate") || (path@connect == "unique.bivariate")){
392                                         self <- TRUE
393                                 }
394                                 path@from <- rep(path@from, each=length(path@to))
395                                 path@to   <- rep(path@to, length(path@from)/length(path@to))
396
397                                 exclude <- rep(FALSE, length(path@from))
398
399                                 # if 'excluderedundant', then exclude b,a if a,b is present
400                                 if (bivariate){
401                                         sortedPairs <- t(apply(matrix(c(path@from, path@to), ncol = 2), 1, sort))
402                                         exclude <- exclude | duplicated(sortedPairs)
403                                 }
404                                 # if 'excludeself', then exclude x,x paths
405                                 if (self){
406                                         exclude <- exclude | (path@from==path@to)
407                                 }
408                                 path@from <- path@from[!exclude]
409                                 path@to   <- path@to[!exclude]
410                                 
411                         }
412                         retval <- removePathRAM(path, A, S)
413                         A <- retval[[1]]
414                         S <- retval[[2]]
415                 }
416         }
417         checkPaths(model, paths)
418         model[['A']] <- A
419         model[['S']] <- S
420         if (!is.null(M)) {
421                 model[['M']] <- M
422         }
423         return(model)
424 }
425
426
427 insertPathRAM <- function(path, A, S) {
428         allfrom <- path@from
429         allto <- path@to
430         allarrows <- path@arrows
431         allfree <- path@free
432         allvalues <- path@values
433         alllabels <- path@labels
434         alllbound <- path@lbound
435         allubound <- path@ubound
436         maxlength <- max(length(allfrom), length(allto))
437         A_free <- A@free
438         A_values <- A@values
439         A_labels <- A@labels
440         A_lbound <- A@lbound
441         A_ubound <- A@ubound
442         S_free   <- S@free
443         S_values <- S@values
444         S_labels <- S@labels
445         S_lbound <- S@lbound
446         S_ubound <- S@ubound
447         for(i in 0:(maxlength - 1)) {
448                 from <- allfrom[[i %% length(allfrom) + 1]]
449                 to <- allto[[i %% length(allto) + 1]]
450                 arrows <- allarrows[[i %% length(allarrows) + 1]]
451                 nextvalue <- allvalues[[i %% length(allvalues) + 1]]
452                 nextfree <- allfree[[i %% length(allfree) + 1]]
453                 nextlabel <- alllabels[[i %% length(alllabels) + 1]]
454                 nextubound <- allubound[[i %% length(allubound) + 1]]
455                 nextlbound <- alllbound[[i %% length(alllbound) + 1]]           
456                 if (arrows == 1) {
457                         A_free[to, from] <- nextfree
458                         A_values[to, from] <- nextvalue
459                         A_labels[to, from] <- nextlabel
460                         A_ubound[to, from] <- nextubound
461                         A_lbound[to, from] <- nextlbound
462                         S_values[to, from] <- 0
463                         S_labels[to, from] <- as.character(NA)
464                         S_free[to, from] <- FALSE
465                         S_values[from, to] <- 0
466                         S_labels[from, to] <- as.character(NA)
467                         S_free[from, to] <- FALSE                       
468                 } else if (arrows == 2) {
469                         S_free[to, from] <- nextfree
470                         S_values[to, from] <- nextvalue
471                         S_labels[to, from] <- nextlabel
472                         S_ubound[to, from] <- nextubound
473                         S_lbound[to, from] <- nextlbound
474                         S_free[from, to] <- nextfree
475                         S_values[from, to] <- nextvalue
476                         S_labels[from, to] <- nextlabel
477                         S_ubound[from, to] <- nextubound
478                         S_lbound[from, to] <- nextlbound
479                         A_values[to, from] <- 0
480                         A_labels[to, from] <- as.character(NA)
481                         A_free[to, from] <- FALSE
482                         A_values[to, from] <- 0
483                         A_labels[to, from] <- as.character(NA)
484                         A_free[to, from] <- FALSE
485                 } else {
486                         stop(paste("Unknown arrow type", arrows, 
487                                         "with source", omxQuotes(from), 
488                                 "and sink", omxQuotes(to)),
489                                 call. = FALSE)
490                 }
491         }
492         A@free <- A_free
493         A@values <-     A_values 
494         A@labels <-     A_labels 
495         A@lbound <-     A_lbound 
496         A@ubound <-     A_ubound 
497         S@free <- S_free   
498         S@values <-     S_values 
499         S@labels <-     S_labels 
500         S@lbound <- S_lbound 
501         S@ubound <- S_ubound 
502         return(list(A, S))
503 }
504
505 removeMeansPathRAM <- function(path, M) {
506         if(is.null(M)) {
507                 return(NULL)
508         }
509         allto <- path@to
510         for(i in 0:(length(allto) - 1)) {
511                 to <- allto[[i %% length(allto) + 1]]
512                 M@free[1, to] <- FALSE
513                 M@values[1, to] <- 0
514                 M@labels[1, to] <- as.character(NA)
515         }
516         return(M)
517 }
518
519 insertMeansPathRAM <- function(path, M) {
520         allto <- path@to
521         arrows <- path@arrows
522         allfree <- path@free
523         allvalues <- path@values
524         alllabels <- path@labels
525         alllbound <- path@lbound
526         allubound <- path@ubound        
527         if (any(arrows != 1)) {
528                 stop(paste('The means path to variable', omxQuotes(to),
529                         'does not contain a single-headed arrow.'), call. = FALSE)
530         }
531         for(i in 0:(length(allto) - 1)) {
532                 to <- allto[[i %% length(allto) + 1]]
533                 nextvalue <- allvalues[[i %% length(allvalues) + 1]]
534                 nextfree <- allfree[[i %% length(allfree) + 1]]
535                 nextlabel <- alllabels[[i %% length(alllabels) + 1]]
536                 nextubound <- allubound[[i %% length(allubound) + 1]]
537                 nextlbound <- alllbound[[i %% length(alllbound) + 1]]
538                 M@free[1, to] <- nextfree
539                 M@values[1, to] <- nextvalue
540                 M@labels[1, to] <- nextlabel
541                 M@ubound[1, to] <- nextubound
542                 M@lbound[1, to] <- nextlbound
543         }
544         return(M)
545 }
546
547 removePathRAM <- function(path, A, S) {
548         allfrom <- path@from
549         allto <- path@to
550         print(path@from)
551         print(path@to)
552         allarrows <- path@arrows
553         maxlength <- max(length(allfrom), length(allto))
554         A_free <- A@free
555         A_values <- A@values
556         A_labels <- A@labels
557         S_free   <- S@free
558         S_values <- S@values
559         S_labels <- S@labels
560         for(i in 0:(maxlength - 1)) {
561                 from <- allfrom[i %% length(allfrom) + 1]
562                 to <- allto[i %% length(allto) + 1]
563                 arrows <- allarrows[i %% length(allarrows) + 1]
564                 if (arrows == 1) {
565                         A_values[to, from] <- 0
566                         A_labels[to, from] <- as.character(NA)
567                         A_free[to, from] <- FALSE               
568                 } else if (arrows == 2) {
569                         S_values[to, from] <- 0
570                         S_labels[to, from] <- as.character(NA)
571                         S_free[to, from] <- FALSE               
572                         S_values[from, to] <- 0
573                         S_labels[from, to] <- as.character(NA)
574                         S_free[from, to] <- FALSE                                       
575                 } else {
576                         stop(paste("Unknown arrow type", arrows, 
577                                         "with source", omxQuotes(from), 
578                                         "and sink", omxQuotes(to)),
579                                         call. = FALSE)
580                 }
581         }
582         A@free <- A_free
583         A@values <-     A_values 
584         A@labels <-     A_labels 
585         S@free <- S_free   
586         S@values <-     S_values 
587         S@labels <-     S_labels        
588         return(list(A, S))
589 }
590
591 createMatrixM <- function(model) {
592         variables <- c(model@manifestVars, model@latentVars)
593         len <- length(variables)
594         names <- list(NULL, variables)
595         values <- matrix(0, 1, len)
596         labels <- matrix(as.character(NA), 1, len)
597         free <- matrix(c(rep.int(FALSE, length(model@manifestVars)),
598                 rep.int(FALSE, length(model@latentVars))), 1, len)
599         retval <- mxMatrix("Full", values = values, free = free, labels = labels, name = "M")
600         dimnames(retval) <- names
601         return(retval)
602 }
603
604 createMatrixA <- function(model) {
605         variables <- c(model@manifestVars, model@latentVars)
606         len <- length(variables)
607         names <- list(variables, variables)
608         values <- matrix(0, len, len)
609         free <- matrix(FALSE, len, len)
610         labels <- matrix(as.character(NA), len, len)
611         retval <- mxMatrix("Full", values = values, free = free, labels = labels, name = "A")
612         dimnames(retval) <- names
613         return(retval)
614 }
615
616 createMatrixS <- function(model) {
617         variables <- c(model@manifestVars, model@latentVars)
618         len <- length(variables)
619         names <- list(variables, variables)
620         values <- matrix(0, len, len)
621         free <- matrix(FALSE, len, len)
622         labels <- matrix(as.character(NA), len, len)
623         retval <- mxMatrix("Symm", values = values, free = free, labels = labels, name = "S")
624         dimnames(retval) <- names
625         return(retval)
626 }
627
628 createMatrixF <- function(model) {
629         variables <- c(model@manifestVars, model@latentVars)
630         len <- length(variables)
631         values <- diag(nrow = length(model@manifestVars), ncol = len)
632         names <- list(model@manifestVars, variables)
633         if (!is.null(model@data) && (model@data@type != 'raw')) {
634                 manifestNames <- rownames(model@data@observed)
635                 extraData <- setdiff(manifestNames, model@manifestVars)
636                 extraVars <- setdiff(model@manifestVars, manifestNames)
637                 if (length(extraData) > 0) {
638                         msg <- paste("The observed data contains the variables:",
639                                 omxQuotes(extraData), "that have not been declared in the",
640                                 "manifest variables.")
641                         stop(msg, call. = FALSE)
642                 }
643                 if (length(extraVars) > 0) {
644                         msg <- paste("The manifest variables include",
645                                 omxQuotes(extraVars), "that have not been found in the",
646                                 "observed data.")
647                         stop(msg, call. = FALSE)
648                 }
649                 dimnames(values) <- names
650                 values <- values[manifestNames,]
651                 names <- list(manifestNames, variables)
652         }
653         free <- matrix(FALSE, length(model@manifestVars), len)
654         labels <- matrix(as.character(NA), length(model@manifestVars), len)
655         retval <- mxMatrix("Full", values = values, free = free, labels = labels, name = "F")
656         dimnames(retval) <- names
657         return(retval)
658 }
659
660 addVariablesAS <- function(oldmatrix, model, newLatent, newManifest) {
661         newLatent <- length(newLatent)
662         newManifest <- length(newManifest)
663         oldmatrix@values <- addVariablesMatrix(oldmatrix@values, 0, 
664                 model, newLatent, newManifest)
665         oldmatrix@free <- addVariablesMatrix(oldmatrix@free, FALSE, 
666                 model, newLatent, newManifest)
667         oldmatrix@labels <- addVariablesMatrix(oldmatrix@labels, as.character(NA), 
668                 model, newLatent, newManifest)
669         oldmatrix@lbound <- addVariablesMatrix(oldmatrix@lbound, as.numeric(NA), 
670                 model, newLatent, newManifest)
671         oldmatrix@ubound <- addVariablesMatrix(oldmatrix@ubound, as.numeric(NA), 
672                 model, newLatent, newManifest)          
673         variables <- c(model@manifestVars, model@latentVars)
674         dimnames(oldmatrix) <- list(variables, variables)
675         return(oldmatrix)
676 }
677
678 addVariablesM <- function(oldmatrix, model, newLatent, newManifest) {
679         oldmatrix@values <- addVariablesMatrixM(oldmatrix@values, 0, 0, model, newLatent, newManifest)
680         oldmatrix@free   <- addVariablesMatrixM(oldmatrix@free, FALSE, TRUE, model, newLatent, newManifest)
681         oldmatrix@labels <- addVariablesMatrixM(oldmatrix@labels, as.character(NA), as.character(NA),
682                 model, newLatent, newManifest) 
683         oldmatrix@lbound <- addVariablesMatrixM(oldmatrix@lbound, as.numeric(NA), as.numeric(NA), 
684                 model, newLatent, newManifest)
685         oldmatrix@ubound <- addVariablesMatrixM(oldmatrix@ubound, as.numeric(NA), as.numeric(NA), 
686                 model, newLatent, newManifest)
687         dimnames(oldmatrix) <- list(NULL, c(model@manifestVars, model@latentVars))
688         return(oldmatrix)
689 }
690
691 removeVariablesAS <- function(oldmatrix, variables) {
692         if (length(variables) > 0) {
693                 for (i in 1:length(variables)) {
694                         index <- match(variables[[i]], dimnames(oldmatrix)[[1]])
695                         oldmatrix@values <- oldmatrix@values[-index, -index]
696                         oldmatrix@free <- oldmatrix@free[-index, -index]
697                         oldmatrix@labels <- oldmatrix@labels[-index, -index]
698                         oldmatrix@lbound <- oldmatrix@lbound[-index, -index]
699                         oldmatrix@ubound <- oldmatrix@ubound[-index, -index]
700                 }
701         }
702         return(oldmatrix)
703 }
704
705
706 addVariablesMatrix <- function(oldmatrix, value, model, newLatent, newManifest) {
707         currentManifest <- length(model@manifestVars) - newManifest
708         currentLatent <- length(model@latentVars) - newLatent
709         newSize <- length(model@manifestVars) + length(model@latentVars)
710         if (currentManifest > 0) {
711                 manifestXmanifest <- oldmatrix[1 : currentManifest, 1 : currentManifest]
712         } else {
713                 manifestXmanifest <- matrix(value, 0, 0)
714         }
715         if (currentLatent > 0) {
716                 latentStart <- currentManifest + 1
717                 latentEnd <- currentManifest + currentLatent
718                 manifestXlatent <- oldmatrix[1 : currentManifest, latentStart : latentEnd]
719                 latentXmanifest <- oldmatrix[latentStart : latentEnd, 1 : currentManifest]
720                 latentXlatent <- oldmatrix[latentStart : latentEnd, latentStart : latentEnd]
721         } else {
722                 manifestXlatent <- matrix(value, 0, 0)
723                 latentXmanifest <- matrix(value, 0, 0)
724                 latentXlatent <- matrix(value, 0, 0)
725         }
726         newtop <- cbind(manifestXmanifest, matrix(value, currentManifest, newManifest),
727                                         manifestXlatent, matrix(value, currentManifest, newLatent)) 
728         newtop <- rbind(newtop, matrix(value, newManifest, newSize))
729         newbottom <- cbind(latentXmanifest, matrix(value, currentLatent, newManifest),
730                                         latentXlatent, matrix(value, currentLatent, newLatent)) 
731         newbottom <- rbind(newbottom, matrix(value, newLatent, newSize))
732         newmatrix <- rbind(newtop, newbottom)
733         return(newmatrix)
734 }
735
736 addVariablesMatrixM <- function(oldmatrix, newLatentValue, newManifestValue, model, newLatent, newManifest) {
737         newManifest <- length(newManifest)
738         newLatent <- length(newLatent)
739         currentManifest <- length(model@manifestVars) - newManifest
740         currentLatent <- length(model@latentVars) - newLatent
741         values <- c(oldmatrix[1, 1:currentManifest], 
742                 rep.int(newManifestValue, newManifest),
743                 oldmatrix[1, (currentManifest + 1) : (currentLatent + currentManifest)],
744                 rep.int(newLatentValue, newLatent))
745         newmatrix <- matrix(values, 1, length(model@manifestVars) + length(model@latentVars))
746         return(newmatrix)
747 }
748
749 replaceMethodRAM <- function(model, index, value) {
750         pair <- imxReverseIdentifier(model, index)
751         namespace <- pair[[1]]
752         name <- pair[[2]]
753         if (namespace == model@name && name == "data") {
754                 model@data <- value
755                 if (requireMeansVector(value)) {
756                         model@objective@M <- "M"
757                 }
758         } else {
759                 model <- imxReplaceMethod(model, index, value)
760         }
761         return(model)
762 }
763