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