Added mxJob interface.
[openmx:openmx.git] / R / MxModel.R
1 setClass(Class = "MxModel",\r
2         representation = representation(\r
3                 matrices = "list",\r
4                 algebras = "list",\r
5                 paths = "data.frame",\r
6                 latentVars = "character",\r
7                 manifestVars = "character",\r
8                 data = "data.frame"))\r
9                 \r
10 setMethod("initialize", "MxModel",\r
11         function(.Object, paths = list(), latentVars = character(),\r
12                 manifestVars = character(), matrices = list(), \r
13                 algebras = list(), data = data.frame()) {\r
14                 if (length(paths) > 0) {\r
15                         .Object <- mxAddPath(.Object, paths)\r
16                 }\r
17                 .Object@latentVars <- latentVars\r
18                 .Object@manifestVars <- manifestVars\r
19                 .Object@matrices <- matrices\r
20                 .Object@algebras <- algebras\r
21                 .Object@data <- data\r
22                 return(.Object)\r
23         }\r
24 )\r
25 \r
26 setMethod("[[", "MxModel",\r
27         function(x, i, j, ..., drop = FALSE) {\r
28                 first <- x@matrices[[i]]\r
29                 second <- x@algebras[[i]]\r
30                 if (is.null(first)) {\r
31                         return(second)\r
32                 } else {\r
33                         return(first)\r
34                 }       \r
35         }\r
36 )\r
37 \r
38 setReplaceMethod("[[", "MxModel",\r
39         function(x, i, j, value) {\r
40                 if (is(value,"MxMatrix")) {\r
41                         if (!is.null(x@algebras[[i]])) {\r
42                                 stop(paste(i, "is already an MxAlgebra object"))\r
43                         }\r
44                         value@name <- i\r
45                         x@matrices[[i]] <- value\r
46                 } else if (is(value,"MxAlgebra")) {\r
47                         if (!is.null(x@matrices[[i]])) {\r
48                                 stop(paste(i, "is already an MxMatrix object"))\r
49                         }
50                         value@name <- i\r
51                         x@algebras[[i]] <- value                \r
52                 } else {\r
53                         stop(paste("Unknown type of value", value))\r
54                 }\r
55                 return(x)\r
56         }\r
57 )\r
58 \r
59 setGeneric("omxAddEntries", function(.Object, entries) {\r
60         return(standardGeneric("omxAddEntries")) } )\r
61 \r
62 setGeneric("omxRemoveEntries", function(.Object, entries) {\r
63         return(standardGeneric("omxRemoveEntries")) } ) \r
64         \r
65 froms <- function(lst) {\r
66   retval <- lapply(lst, function(x) { return(x$from) } )\r
67   return(retval)\r
68 }       \r
69 \r
70 tos <- function(lst) {\r
71   retval <- lapply(lst, function(x) { return(x$to) } )\r
72   return(retval)\r
73 }       \r
74 \r
75 omxMappend <- function(...) {\r
76     args <- list(...)\r
77         return(mappendHelper(args, list()))\r
78 }\r
79 \r
80 mappendHelper <- function(lst, result) {\r
81         if (length(lst) == 0) {\r
82                 return(result)\r
83         } else if (length(lst) == 1) {\r
84                 return(append(result,lst[[1]]))\r
85         } else {\r
86                 return(mappendHelper(lst[2:length(lst)], append(result, lst[[1]])))\r
87         }\r
88 }\r
89 \r
90 omxModel <- function(model=NULL, ..., remove=FALSE, manifestVars=NULL, latentVars=NULL) {\r
91         if(is.null(model)) {\r
92                 model <- new("MxModel") \r
93         }\r
94         lst <- list(...)\r
95         if(class(model)[[1]] != "MxModel") {\r
96                 stop("First argument is not an MxModel object")\r
97         }\r
98         if(remove == TRUE) {\r
99                 model <- omxRemoveEntries(model, mappendHelper(lst, list()))\r
100                 if ( !is.null(manifestVars) ) {\r
101                         model@manifestVars <- setdiff(model@manifestVars, manifestVars)\r
102                 }\r
103                 if ( !is.null(latentVars) ) {\r
104                         model@latentVars <- setdiff(model@latentVars, latentVars)\r
105                 }                               \r
106         } else {\r
107                 model <- omxAddEntries(model, mappendHelper(lst, list()))\r
108                 if ( !is.null(manifestVars) ) {\r
109                         tmp <- append(model@manifestVars, manifestVars)\r
110                         model@manifestVars <- unique(tmp)\r
111                 }\r
112                 if ( !is.null(latentVars) ) {\r
113                         tmp <- append(model@latentVars, latentVars)\r
114                         model@latentVars <- unique(tmp)\r
115                 }               \r
116         }\r
117         return(model)\r
118 }\r
119 \r
120 filterEntries <- function(entries, paths, matrices, algebras) {\r
121         if (length(entries) == 0) {\r
122                 return(list(paths, matrices, algebras))\r
123         }\r
124         head <- entries[[1]]\r
125         if (is(head, "MxMatrix")) {\r
126                 matrices <- append(matrices, head)\r
127         } else if (is(head, "MxAlgebra")) {\r
128                 algebras <- append(algebras, head)\r
129         } else if (omxIsPath(head)) {\r
130                 paths <- append(paths, head)\r
131         } else {\r
132                 stop(paste("Unkown object:", head))\r
133         }\r
134         return(filterEntries(entries[-1], paths, matrices, algebras))\r
135 }\r
136         \r
137 setMethod("omxAddEntries", "MxModel", \r
138         function(.Object, entries) {\r
139                 if (length(entries) < 1) {\r
140                         return(.Object)\r
141                 }\r
142                 threeTuple <- filterEntries(entries, list(), list(), list())\r
143                 paths <- threeTuple[[1]]\r
144                 matrices <- threeTuple[[2]]\r
145                 algebras <- threeTuple[[3]]\r
146                 if (any(is.na(froms(paths))) || any(is.na(tos(paths)))) {\r
147                         stop("The \'from\' field or the \'to\' field contains an NA")\r
148                 }\r
149                 if (length(paths) > 0) for(i in 1:length(paths)) {\r
150                         .Object <- omxAddSinglePath(.Object, paths[[i]])\r
151                 }\r
152                 if (length(matrices) > 0) for(i in 1:length(matrices)) {\r
153                         .Object <- omxAddSingleMatrix(.Object, matrices[[i]])\r
154                 }\r
155                 if (length(algebras) > 0) for(i in 1:length(algebras)) {\r
156                         .Object <- omxAddSingleAlgebra(.Object, algebras[[i]])\r
157                 }\r
158                 return(.Object)\r
159         }\r
160 )\r
161 \r
162 setMethod("omxRemoveEntries", "MxModel", \r
163         function(.Object, entries) {\r
164                 if (length(entries) < 1) {\r
165                         return(.Object)\r
166                 }\r
167                 threeTuple <- filterEntries(entries, list(), list(), list())\r
168                 paths <- threeTuple[[1]]\r
169                 matrices <- threeTuple[[2]]\r
170                 algebras <- threeTuple[[3]]             \r
171                 if (any(is.na(froms(paths))) || any(is.na(tos(paths)))) {\r
172                         stop("The \'from\' field or the \'to\' field contains an NA")\r
173                 }               \r
174                 if (length(paths) > 0) for(i in 1:length(paths)) {\r
175                         .Object <- omxRemoveSinglePath(.Object, paths[[i]])\r
176                 }\r
177                 if (length(matrices) > 0) for(i in 1:length(matrices)) {\r
178                         .Object <- omxRemoveSingleMatrix(.Object, matrices[[i]])\r
179                 }\r
180                 if (length(algebras) > 0) for(i in 1:length(algebras)) {\r
181                         .Object <- omxRemoveSingleAlgebra(.Object, algebras[[i]])\r
182                 }\r
183                 return(.Object)\r
184         }\r
185 )\r
186 \r
187 omxAddSingleMatrix <- function(.Object, matrix) {\r
188         .Object[[matrix@name]] <- matrix\r
189         return(.Object)\r
190 }\r
191 \r
192 omxAddSingleAlgebra <- function(.Object, algebra) {\r
193         .Object[[algebra@name]] <- algebra\r
194         return(.Object)\r
195 }\r
196 \r
197 omxAddSinglePath <- function(.Object, path) {\r
198         if (nrow(.Object@paths) > 0) {\r
199                 fromExists <- (.Object@paths['from'] == path[['from']])\r
200                 toExists <- (.Object@paths['to'] == path[['to']])\r
201                 replace <- any(fromExists & toExists, na.rm=TRUE)\r
202                 morfExists <- (.Object@paths['from'] == path[['to']])\r
203                 otExists <- (.Object@paths['to'] == path[['from']])\r
204                 oppositeExists <- any(morfExists & otExists, na.rm=TRUE)\r
205                 if (oppositeExists) {\r
206                         newArrow <- !is.null(path[['arrows']])\r
207                         oldArrow <- !is.null(.Object@paths[morfExists & otExists,'arrows'])\r
208                         if (oldArrow && .Object@paths[morfExists & otExists,'arrows'] == 2) {\r
209                                         fromTemp <- as.vector(.Object@paths[morfExists & otExists,'from'])\r
210                                         toTemp <- as.vector(.Object@paths[morfExists & otExists,'to'])\r
211                                         fUnique <- lapply(.Object@paths['from'], paste, collapse='')[[1]]\r
212                                         .Object@paths[morfExists & otExists, 'from'] <- fUnique\r
213                                         .Object@paths[.Object@paths['from'] == fUnique, 'to'] <- fromTemp\r
214                                         .Object@paths[.Object@paths['from'] == fUnique, 'from'] <- toTemp\r
215                                         fromExists <- (.Object@paths['from'] == path[['from']])\r
216                                         toExists <- (.Object@paths['to'] == path[['to']])\r
217                                         replace <- TRUE\r
218                         } else if (newArrow && path[['arrows']] == 2) {\r
219                                         tmp <- path[['from']]\r
220                                         path[['from']] <- path[['to']]\r
221                                         path[['to']] <- tmp\r
222                                         fromExists <- (.Object@paths['from'] == path[['from']])\r
223                                         toExists <- (.Object@paths['to'] == path[['to']])\r
224                                         replace <- TRUE\r
225                         }\r
226                 }\r
227                 if (replace) {\r
228                         ids <- names(path)                      \r
229                         for(i in 1:length(path)) {\r
230                                 id <- ids[[i]]\r
231                                 .Object@paths[fromExists & toExists,id] <- path[[id]]\r
232                         }\r
233                 } else {\r
234                         .Object@paths <- merge(.Object@paths, \r
235                                 data.frame(path, stringsAsFactors = FALSE), all=TRUE)\r
236                 }\r
237         } else {\r
238                 .Object@paths <- data.frame(path, stringsAsFactors = FALSE)\r
239         }\r
240         fromExists <- (.Object@paths['from'] == path[['from']])\r
241         toExists <- (.Object@paths['to'] == path[['to']])\r
242         field <- .Object@paths[fromExists & toExists, 'arrows']\r
243         if (!is.null(field) && !is.na(field)  \r
244                         && (field == 2) \r
245                         && (path[['from']] > path[['to']])) {\r
246                 fromTemp <- as.vector(.Object@paths[morfExists & otExists,'from'])\r
247                 toTemp <- as.vector(.Object@paths[morfExists & otExists,'to'])\r
248                 fUnique <- lapply(.Object@paths['from'], paste, collapse='')[[1]]\r
249                 .Object@paths[morfExists & otExists, 'from'] <- fUnique\r
250                 .Object@paths[.Object@paths['from'] == fUnique, 'to'] <- fromTemp\r
251                 .Object@paths[.Object@paths['from'] == fUnique, 'from'] <- toTemp\r
252         }       \r
253         return(.Object)\r
254 }\r
255 \r
256 omxRemoveSinglePath <- function(.Object, path) {\r
257         if (nrow(.Object@paths) > 0) {\r
258                 .Object@paths <- subset(.Object@paths, to != path[['to']] | from != path[['from']])\r
259                 if (nrow(.Object@paths) > 0) {          \r
260                         morfExists <- (.Object@paths['from'] == path[['to']])\r
261                         otExists <- (.Object@paths['to'] == path[['from']])\r
262                         oppositeExists <- any(morfExists & otExists, na.rm=TRUE)\r
263                         if (oppositeExists) {\r
264                                 check1 <- !is.null(path[['arrows']]) && path[['arrows']] == 2\r
265                                 check2 <- !is.null(.Object@paths[morfExists & otExists,'arrows']) &&\r
266                                                         .Object@paths[morfExists & otExists,'arrows'] == 2\r
267                                 if (check1 || check2) {\r
268                                         .Object@paths <- subset(.Object@paths, \r
269                                                 to != path[['from']] | from != path[['to']])\r
270                                 }\r
271                         }\r
272                 }               \r
273         }               \r
274         return(.Object)\r
275 }\r
276 \r
277 omxRemoveSingleMatrix <- function(.Object, matrix) {\r
278         .Object[[matrix@name]] <- NULL\r
279         return(.Object)\r
280 }\r
281 \r
282 omxRemoveSingleAlgebra <- function(.Object, algebra) {\r
283         .Object[[algebra@name]] <- NULL\r
284         return(.Object)\r
285 }\r
286 \r
287 mxModel <- function(model = NULL, ..., remove = FALSE, manifestVars = NULL, latentVars = NULL) {\r
288         omxModel(model, ..., remove = remove, manifestVars = manifestVars, latentVars = latentVars)\r
289 }\r
290 \r